Theory CZH_Sets_MIF

(* Copyright 2021 (C) Manuel Eberl *)

section‹Mutliway If›
theory CZH_Sets_MIF
  imports Main
begin

text‹
The code that is presented in this section was originally written 
by Manuel Eberl and appeared in a post on the mailing list of Isabelle:
\cite{eberl_syntax_2021}.
The code was ported with minor amendments by the author of this work.
›

abbreviation multi_If :: "bool ⇒ 'a ⇒ 'a ⇒ 'a"
  where "multi_If ≡ If"

nonterminal if_clauses and if_clause

syntax
  "_if_block" :: "if_clauses ⇒ 'a" ("(1if _)" [12] 10)
  "_if_clause"  :: "bool ⇒ 'a ⇒ if_clause" ("(2_ ⇒/ _)" 13)
  "_if_final" :: "'a ⇒ if_clauses" ("otherwise ⇒ _")
  "_if_cons" :: "[if_clause, if_clauses] ⇒ if_clauses" ("_ /| _" [13, 12] 12)

syntax (ASCII)
  "_if_clause" :: "[pttrn, 'a] ⇒ if_clause" ("(2_ =>/ _)" 13)

translations
  "_if_block (_if_cons (_if_clause b t) (_if_final e))"
    ⇌ "CONST multi_If b t e"
  "_if_block (_if_cons b (_if_cons c cs))"
    ⇌ "_if_block (_if_cons b (_if_final (_if_block (_if_cons c cs))))"
  "_if_block (_if_final e)" ⇀ "e"

text‹\newpage›

end

Theory CZH_Utilities

(* Copyright 2021 (C) Mihails Milehins *)

section‹Utilities›
theory CZH_Utilities
  imports Main
  keywords "lemmas_with" :: thy_decl
begin


text‹
Then command text‹lemmas_with› is a copy (with minor amendments to formatting) 
of the command with the identical name that was introduced by Ondřej Kunčar in
text‹HOL-Types_To_Sets.Prerequisites›. A copy of the function was produced, 
primarily, to avoid the unnecessary dependency of this work on the 
axioms associated with the framework ‹Types-To-Sets›.
›

ML‹
val _ =
  Outer_Syntax.local_theory'
    command_keyword‹lemmas_with› 
    "note theorems with (the same) attributes"
    (
      Parse.attribs --| keyword‹:› --
      Parse_Spec.name_facts -- 
      Parse.for_fixes >> 
      (
        fn (((attrs),facts), fixes) =>
          #2 oo Specification.theorems_cmd Thm.theoremK
          (map (apsnd (map (apsnd (fn xs => attrs@xs)))) facts) fixes
      )
    )
›

text‹\newpage›

end

Theory CZH_Introduction

(* Copyright 2021 (C) Mihails Milehins *)

chapter‹Introduction›
theory CZH_Introduction
  imports ZFC_in_HOL.ZFC_Typeclasses
begin



section‹Background›


text‹
This article presents a foundational framework
that will be used for the formalization of
elements of the theory of 1-categories in the object logic 
‹ZFC in HOL› (\cite{paulson_zermelo_2019}, also see
\cite{barkaoui_partizan_2006}) of the formal proof assistant 
‹Isabelle› \cite{paulson_natural_1986} in future articles.
It is important to note that this chapter serves as 
an introduction to the entire development and not merely
its foundational part. 

There already exist several formalizations of the foundations of category 
theory in Isabelle. In the context of the work presented here, the most relevant
formalizations (listed in the chronological order) are 
\cite{okeefe_category_2005}, \cite{katovsky_category_2010} and 
\cite{stark_category_2016}. 
Arguably, the most well developed and maintained entry is 
\cite{stark_category_2016}: it subsumes the majority of the content of 
\cite{okeefe_category_2005} and \cite{katovsky_category_2010}.

From the perspective of the methodology that was chosen for the formalization, 
this work differs significantly from the aforementioned previous work.
In particular, the categories are modelled as terms of the type typ‹V› 
and no attempt is made to generalize the concept of a category to arbitrary 
types. The inspiration for the chosen approach is drawn from  
\cite{feferman_set-theoretical_1969},
\cite{sica_doing_2006} and \cite{shulman_set_2008}.

The primary references for this work are 
‹Categories for the Working Mathematician› \cite{mac_lane_categories_2010}
by Saunders Mac Lane, ‹Category Theory in Context› 
by Emily Riehl \cite{riehl_category_2016} and 
‹Categories and Functors› by Bodo Pareigis \cite{bodo_categories_1970}. 
The secondary sources of information include the textbooks 
\cite{adamek_abstract_2006} and \cite{hungerford_algebra_2003}, 
as well as several online encyclopedias
(including \cite{noauthor_nlab_nodate}, 
\cite{noauthor_wikipedia_2001}, 
\cite{noauthor_proofwiki_nodate}
and \cite{noauthor_encyclopedia_nodate}). 
Of course, inspiration was also drawn from the previous formalizations of 
category theory in Isabelle. 

It is likely that none of the content that is formalized in this work
is original in nature. However, explicit citations
are not provided for many results that were deemed to be trivial.
›



section‹Related and previous work›


text‹
To the best knowledge of the author, this work is the first attempt
to develop a formalization of elements of category theory in the 
object logic ZFC in HOL by modelling categories as terms of the type typ‹V›.
However, it should be noted that the formalization of category theory in
\cite{katovsky_category_2010} largely rested 
on the object logic HOL/ZF \cite{barkaoui_partizan_2006}, which is 
equiconsistent with the ZFC in HOL \cite{paulson_zermelo_2019}. 
Nonetheless, in \cite{katovsky_category_2010}, the objects and arrows
associated with categories were modelled as terms of arbitrary
types. The object logic HOL/ZF was used for the exposition of 
the category ‹Set› of all sets and functions between them 
and a variety of closely related concepts.
In this sense, the methodology employed in 
\cite{katovsky_category_2010} could be seen as a combination of the 
methodology employed in this work and the methodology followed in
\cite{okeefe_category_2005} and \cite{stark_category_2016}.
Furthermore, in \cite{chen_hotg_2021}, 
the authors have experimented with the formalization of category 
theory in Higher-Order Tarski-Grothendieck (HOTG)
theory \cite{brown_higher-order_2019} using a methodology that 
shares many similarities with the approach that was chosen in this study.

The formalizations of various elements of category theory 
in other proof assistants are abundant.
While a survey of such formalizations is outside of the scope of
this work, it is important to note that there exist at least two examples 
of the formalization of elements of category theory in a set-theoretic setting
similar to the one that is used in this work. 
More specifically, elements of category theory were formalized in
the Tarski-Grothendieck Set Theory in the Mizar proof assistant 
\cite{noauthor_association_nodate} (and
published in the associated electronic journal 
\cite{grabowski_preface_2014}) 
and the proof assistant Metamath
\cite{megill_metamath_2019}.
The following references contain some of the 
relevant articles in \cite{grabowski_preface_2014}, but the list may not be 
exhaustive: 
\cite{bylinski_introduction_1990, bylinski_subcategories_1990, 
bylinski_opposite_1991, trybulec_natural_1991, 
bylinski_category_1991, muzalewski_categories_1991,
trybulec_isomorphisms_1991, muzalewski_category_1991,
muzalewski_category_1991-1, bancerek_comma_1991,
bylinski_products_1991, trybulec_isomorphisms_1992, 
bylinski_cartesian_1992, bancerek_categorial_1996,
trybulec_categories_1996, bancerek_indexed_1996,
trybulec_functors_1996, nieszczerzewski_category_1997,
kornilowicz_categories_1997,
kornilowicz_composition_1998, 
bancerek_concrete_2001,
kornilowicz_products_2012,
riccardi_object-free_2013,
golinski_coproducts_2013, 
riccardi_categorical_2015,
riccardi_exponential_2015}.
›

end

Theory CZH_Sets_Introduction

(* Copyright 2021 (C) Mihails Milehins *)

chapter‹Set Theory for Category Theory›

section‹Introduction›
theory CZH_Sets_Introduction
  imports 
    CZH_Introduction
    CZH_Sets_MIF
    CZH_Utilities
    Intro_Dest_Elim.IHOL_IDE
    Conditional_Simplification.IHOL_CS
    ZFC_in_HOL.Cantor_NF
    "HOL-Eisbach.Eisbach"
begin



subsection‹Background›


text‹
This chapter presents a formalization of the elements of set theory in 
the object logic ‹ZFC in HOL› (\cite{paulson_zermelo_2019}, also see
\cite{barkaoui_partizan_2006})
of the formal proof assistant Isabelle \cite{paulson_natural_1986}.
The emphasis of this work is on the improvement of the convenience of the 
formalization of abstract mathematics internalized in the type typ‹V›.
›



subsection‹References, related and previous work›


text‹
The results that are presented in this chapter cannot be traced to a single
source of information. Nonetheless, the results are not original. 
A significant number of these results was carried over (with amendments) 
from the main library of Isabelle/HOL \cite{noauthor_isabellehol_2020}. 
Other results were inspired by elements of the content of the books 
‹Introduction to Axiomatic Set Theory› by G. Takeuti 
and W. M. Zaring \cite{takeuti_introduction_1971}, ‹Theory of Sets› 
by N. Bourbaki \cite{bourbaki_elements_nodate} and ‹Algebra› by 
T. W. Hungerford \cite{hungerford_algebra_2003}.
Furthermore, several online encyclopedias and forums 
(including Wikipedia \cite{noauthor_wikipedia_2001}, 
ProofWiki \cite{noauthor_proofwiki_nodate}, 
Encyclopedia of Mathematics \cite{noauthor_encyclopedia_nodate},
nLab \cite{noauthor_nlab_nodate} and Mathematics Stack Exchange) 
were used consistently throughout the development of this chapter. 
Inspiration for the work presented in this chapter has also been drawn 
from a similar ongoing project
in the formalization of mathematics in the system 
HOTG (Higher Order Tarski-Grothendieck) 
\cite{brown_higher-order_2019, chen_hotg_2021}.

It should also be mentioned that the Isabelle/HOL and the Isabelle/ML code 
from the main distribution of Isabelle2020 and certain posts on the 
mailing list of Isabelle were frequently reused
(with amendments) during the development of this chapter. Some of the 
specific examples of such reuse are 
\begin{itemize}
\item The adoption of the implementation of
the command @{command lemmas_with} that is available as part of 
the framework Types-To-Sets in the main distribution of Isabelle2020.
\item The notation for the ``multiway-if'' was written
by Manuel Eberl and appeared in a post on the mailing list of Isabelle:
\cite{eberl_syntax_2021}.
\end{itemize}
›

hide_const (open) list.set Sum subset 

lemmas ord_of_nat_zero = ord_of_nat.simps(1)



subsection‹Notation›

abbreviation (input) qm (‹(_ ? _ : _)› [0, 0, 10] 10) 
  where "C ? A : B ≡ if C then A else B"
abbreviation (input) if2 where "if2 a b ≡ (λi. (i = 0 ? a : b))"



subsection‹Further foundational results›

lemma theD:
  assumes "∃!x. P x" and "x = (THE x. P x)"
  shows "P x" and "P y ⟹ x = y"
  using assms by (metis theI)+

lemmas [intro] = bij_betw_imageI

lemma bij_betwE[elim]:
  assumes "bij_betw f A B" and "⟦ inj_on f A; f ` A = B ⟧ ⟹ P"
  shows P
  using assms unfolding bij_betw_def by auto

lemma bij_betwD[dest]:
  assumes "bij_betw f A B"
  shows "inj_on f A" and "f ` A = B"
  using assms by auto

text‹\newpage›

end

Theory CZH_Sets_Sets

(* Copyright 2021 (C) Mihails Milehins *)

section‹Further set algebra and other miscellaneous results›
theory CZH_Sets_Sets
  imports CZH_Sets_Introduction
begin



subsection‹Background›


text‹
This section presents further set algebra and various elementary properties
of sets.

Many of the results that are presented in this section
were carried over (with amendments) from the theories text‹Set› 
and text‹Complete_Lattices› in the main library.
›

declare elts_sup_iff[simp del] 



subsection‹Further notation›


subsubsection‹Set membership›

abbreviation vmember :: "V ⇒ V ⇒ bool" ("(_/ ∈∘ _)" [51, 51] 50) 
  where "vmember x A ≡ (x ∈ elts A)"
notation vmember ("'(∈∘')")
  and vmember ("(_/ ∈∘ _)" [51, 51] 50)

abbreviation not_vmember :: "V ⇒ V ⇒ bool" ("(_/ ∉∘ _)" [51, 51] 50) 
  where "not_vmember x A ≡ (x ∉ elts A)" 
notation
  not_vmember ("'(∉∘')") and
  not_vmember ("(_/ ∉∘ _)" [51, 51] 50)


subsubsection‹Subsets›

abbreviation vsubset :: "V ⇒ V ⇒ bool"
  where "vsubset ≡ less"
abbreviation vsubset_eq :: "V ⇒ V ⇒ bool"
  where "vsubset_eq ≡ less_eq"

notation vsubset ("'(⊂∘')") 
  and vsubset ("(_/ ⊂∘ _)" [51, 51] 50) 
  and vsubset_eq ("'(⊆∘')") 
  and vsubset_eq ("(_/ ⊆∘ _)" [51, 51] 50)


subsubsection‹Ball›

syntax
  "_VBall" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∀(_/∈∘_)./ _)" [0, 0, 10] 10)
  "_VBex" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∃(_/∈∘_)./ _)" [0, 0, 10] 10)
  "_VBex1" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∃!(_/∈∘_)./ _)" [0, 0, 10] 10)

translations
  "∀x∈∘A. P" ⇌ "CONST Ball (CONST elts A) (λx. P)"
  "∃x∈∘A. P" ⇌ "CONST Bex (CONST elts A) (λx. P)"
  "∃!x∈∘A. P" ⇀ "∃!x. x ∈∘ A ∧ P"


subsubsection‹‹VLambda››


text‹The following notation was adapted from \cite{paulson_hereditarily_2013}.›

syntax "_vlam" :: "[pttrn, V, V] ⇒ V" (‹(3λ_∈∘_./ _)› 10)
translations "λx∈∘A. f" ⇌ "CONST VLambda A (λx. f)"


subsubsection‹Intersection and union›

abbreviation vintersection :: "V ⇒ V ⇒ V" (infixl "∩∘" 70)
  where "(∩∘) ≡ (⊓)"
notation vintersection (infixl "∩∘" 70)

abbreviation vunion :: "V ⇒ V ⇒ V"  (infixl "∪∘" 65)
  where "vunion ≡ sup"
notation vunion (infixl "∪∘" 65)

abbreviation VInter :: "V ⇒ V" (‹⋂∘›)
  where "⋂∘ A ≡ ⨅ (elts A)"
notation VInter (‹⋂∘›)

abbreviation VUnion :: "V ⇒ V" (‹⋃∘›)
  where "⋃∘A ≡ ⨆ (elts A)"
notation VUnion (‹⋃∘›)


subsubsection‹Miscellaneous›

notation app (‹_⦇_⦈› [999, 50] 999)
notation vtimes (infixr "×∘" 80)



subsection‹Elementary results.›

lemma vempty_nin[simp]: "a ∉∘ 0" by simp

lemma vemptyE:
  assumes "A ≠ 0"
  obtains x where "x ∈∘ A" 
  using assms trad_foundation by auto

lemma in_set_CollectI:
  assumes "P x" and "small {x. P x}"
  shows "x ∈∘ set {x. P x}"
  using assms by simp

lemma small_setcompr2:
  assumes "small {f x y | x y. P x y}" and "a ∈∘ set {f x y | x y. P x y}"
  obtains x' y' where "a = f x' y'" and "P x' y'"
  using assms by auto

lemma in_small_setI:
  assumes "small A" and "x ∈ A"
  shows "x ∈∘ set A"
  using assms by simp

lemma in_small_setD:
  assumes "x ∈∘ set A" and "small A" 
  shows "x ∈ A"
  using assms by simp

lemma in_small_setE:
  assumes "a ∈∘ set A" and "small A"
  obtains "a ∈ A"
  using assms by auto

lemma small_set_vsubset:
  assumes "small A" and "A ⊆ elts B"
  shows "set A ⊆∘ B"
  using assms by auto

lemma some_in_set_if_set_neq_vempty[simp]:
  assumes "A ≠ 0"
  shows "(SOME x. x ∈∘ A) ∈∘ A"
  by (meson assms someI_ex vemptyE)

lemma small_vsubset_set[intro, simp]:
  assumes "small B" and "A ⊆ B"
  shows "set A ⊆∘ set B"
  using assms by (auto simp: subset_iff_less_eq_V)

lemma vset_neq_1:
  assumes "b ∉∘ A" and "a ∈∘ A"
  shows "b ≠ a"
  using assms by auto

lemma vset_neq_2:
  assumes "b ∈∘ A" and "a ∉∘ A"
  shows "b ≠ a"
  using assms by auto

lemma nin_vinsertI:
  assumes "a ≠ b" and "a ∉∘ A"
  shows "a ∉∘ vinsert b A"
  using assms by clarsimp

lemma vsubset_if_subset:
  assumes "elts A ⊆ elts B"
  shows "A ⊆∘ B"
  using assms by auto

lemma small_set_comprehension[simp]: "small {A i | i. i ∈∘ I}"
proof(rule smaller_than_small)
  show "small (A ` elts I)" by auto
qed auto



subsection‹‹VBall››

lemma vball_cong:
  assumes "A = B" and "⋀x. x ∈∘ B ⟹ P x ⟷ Q x"
  shows "(∀x∈∘A. P x) ⟷ (∀x∈∘B. Q x)"
  by (simp add: assms)

lemma vball_cong_simp[cong]:
  assumes "A = B" and "⋀x. x ∈∘ B =simp=> P x ⟷ Q x " 
  shows "(∀x∈∘A. P x) ⟷ (∀x∈∘B. Q x)"
  using assms by (simp add: simp_implies_def)



subsection‹‹VBex››

lemma vbex_cong:
  assumes "A = B" and  "⋀x. x ∈∘ B ⟹ P x ⟷ Q x" 
  shows "(∃x∈∘A. P x) ⟷ (∃x∈∘B. Q x)"
  using assms by (simp cong: conj_cong)

lemma vbex_cong_simp[cong]:
  assumes "A = B" and "⋀x. x ∈∘ B =simp=> P x ⟷ Q x "
  shows "(∃x∈∘A. P x) ⟷ (∃x∈∘B. Q x)"
  using assms by (simp add:  simp_implies_def)



subsection‹Subset›


text‹Rules.›

lemma vsubset_antisym: 
  assumes "A ⊆∘ B" and "B ⊆∘ A" 
  shows "A = B"
  using assms by simp

lemma vsubsetI:
  assumes "⋀x. x ∈∘ A ⟹ x ∈∘ B"
  shows "A ⊆∘ B"
  using assms by auto

lemma vpsubsetI:
  assumes "A ⊆∘ B" and "x ∉∘ A" and "x ∈∘ B"
  shows "A ⊂∘ B"
  using assms unfolding less_V_def by auto

lemma vsubsetD:
  assumes "A ⊆∘ B"
  shows "⋀x. x ∈∘ A ⟹ x ∈∘ B"
  using assms by auto

lemma vsubsetE:
  assumes "A ⊆∘ B" and "(⋀x. x ∈∘ A ⟹ x ∈∘ B) ⟹ P"
  shows P
  using assms by auto

lemma vpsubsetE:
  assumes "A ⊂∘ B"
  obtains x where "A ⊆∘ B" and "x ∉∘ A" and "x ∈∘ B"
  using assms unfolding less_V_def by (meson V_equalityI vsubsetE)

lemma vsubset_iff: "A ⊆∘ B ⟷ (∀t. t ∈∘ A ⟶ t ∈∘ B)" by blast


text‹Elementary properties.›

lemma vsubset_eq: "A ⊆∘ B ⟷ (∀x∈∘A. x ∈∘ B)" by auto

lemma vsubset_transitive[intro]: 
  assumes "A ⊆∘ B" and "B ⊆∘ C"
  shows "A ⊆∘ C"
  using assms by simp

lemma vsubset_reflexive: "A ⊆∘ A" by simp


text‹Set operations.›

lemma vsubset_vempty: "0 ⊆∘ A" by simp

lemma vsubset_vsingleton_left: "set {a} ⊆∘ A ⟷ a ∈∘ A" by auto

lemmas vsubset_vsingleton_leftD[dest] = vsubset_vsingleton_left[THEN iffD1]
  and vsubset_vsingleton_leftI[intro] = vsubset_vsingleton_left[THEN iffD2]

lemma vsubset_vsingleton_right: "A ⊆∘ set {a} ⟷ A = set {a} ∨ A = 0" 
  by (auto intro!: vsubset_antisym)

lemmas vsubset_vsingleton_rightD[dest] = vsubset_vsingleton_right[THEN iffD1]
  and vsubset_vsingleton_rightI[intro] = vsubset_vsingleton_right[THEN iffD2]

lemma vsubset_vdoubleton_leftD[dest]:
  assumes "set {a, b} ⊆∘ A"
  shows "a ∈∘ A" and "b ∈∘ A"
  using assms by auto

lemma vsubset_vdoubleton_leftI[intro]:
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "set {a, b} ⊆∘ A"
  using assms by auto

lemma vsubset_vinsert_leftD[dest]:
  assumes "vinsert a A ⊆∘ B"
  shows "A ⊆∘ B"
  using assms by auto

lemma vsubset_vinsert_leftI[intro]:
  assumes "A ⊆∘ B" and "a ∈∘ B"
  shows "vinsert a A ⊆∘ B" 
  using assms by auto

lemma vsubset_vinsert_vinsertI[intro]:
  assumes "A ⊆∘ vinsert b B"
  shows "vinsert b A ⊆∘ vinsert b B"
  using assms by auto

lemma vsubset_vinsert_rightI[intro]:
  assumes "A ⊆∘ B"
  shows "A ⊆∘ vinsert b B"
  using assms by auto
                                     
lemmas vsubset_VPow = VPow_le_VPow_iff

lemmas vsubset_VPowD = vsubset_VPow[THEN iffD1]
  and vsubset_VPowI = vsubset_VPow[THEN iffD2]


text‹Special properties.›

lemma vsubset_contraD:
  assumes "A ⊆∘ B" and "c ∉∘ B" 
  shows "c ∉∘ A" 
  using assms by auto



subsection‹Equality›


text‹Rules.›

lemma vequalityD1: 
  assumes "A = B"
  shows "A ⊆∘ B" 
  using assms by simp

lemma vequalityD2: 
  assumes "A = B"
  shows "B ⊆∘ A" 
  using assms by simp

lemma vequalityE: 
  assumes "A = B" and "⟦ A ⊆∘ B; B ⊆∘ A ⟧ ⟹ P" 
  shows P
  using assms by simp

lemma vequalityCE[elim]: 
  assumes "A = B" and "⟦ c ∈∘ A; c ∈∘ B ⟧ ⟹ P" and "⟦ c ∉∘ A; c ∉∘ B ⟧ ⟹ P" 
  shows P
  using assms by auto



subsection‹Binary intersection›

lemma vintersection_def: "A ∩∘ B = set {x. x ∈∘ A ∧ x ∈∘ B}" 
  by (metis Int_def inf_V_def)

lemma small_vintersection_set[simp]: "small {x. x ∈∘ A ∧ x ∈∘ B}" 
  by (rule down[of _ A]) auto


text‹Rules.›

lemma vintersection_iff[simp]: "x ∈∘ A ∩∘ B ⟷ x ∈∘ A ∧ x ∈∘ B" 
  unfolding vintersection_def by simp

lemma vintersectionI[intro!]: 
  assumes "x ∈∘ A" and "x ∈∘ B" 
  shows "x ∈∘ A ∩∘ B" 
  using assms by simp

lemma vintersectionD1[dest]: 
  assumes "x ∈∘ A ∩∘ B"
  shows "x ∈∘ A" 
  using assms by simp

lemma vintersectionD2[dest]: 
  assumes "x ∈∘ A ∩∘ B"
  shows "x ∈∘ B" 
  using assms by simp

lemma vintersectionE[elim!]: 
  assumes "x ∈∘ A ∩∘ B" and "x ∈∘ A ⟹ x ∈∘ B ⟹ P" 
  shows P 
  using assms by simp


text‹Elementary properties.›

lemma vintersection_intersection: "A ∩∘ B = set (elts A ∩ elts B)"
  unfolding inf_V_def by simp

lemma vintersection_assoc: "A ∩∘ (B ∩∘ C) = (A ∩∘ B) ∩∘ C" by auto

lemma vintersection_commutativity: "A ∩∘ B = B ∩∘ A" by auto


text‹Previous set operations.›

lemma vsubset_vintersection_right: "A ⊆∘ (B ∩∘ C) = (A ⊆∘ B ∧ A ⊆∘ C)" 
  by clarsimp

lemma vsubset_vintersection_rightD[dest]:
  assumes "A ⊆∘ (B ∩∘ C)"
  shows "A ⊆∘ B" and "A ⊆∘ C"
  using assms by auto

lemma vsubset_vintersection_rightI[intro]:
  assumes "A ⊆∘ B" and "A ⊆∘ C" 
  shows "A ⊆∘ (B ∩∘ C)"
  using assms by auto


text‹Set operations.›

lemma vintersection_vempty: "0 ⊆∘ A" by simp

lemma vintersection_vsingleton: "a ∈∘ set {a}" by simp

lemma vintersection_vdoubleton: "a ∈∘ set {a, b}" and "b ∈∘ set {a, b}"  
  by simp_all

lemma vintersection_VPow[simp]: "VPow (A ∩∘ B) = VPow A ∩∘ VPow B" by auto


text‹Special properties.›

lemma vintersection_function_mono:
  assumes "mono f"
  shows "f (A ∩∘ B) ⊆∘ f A ∩∘ f B"
  using assms by (fact mono_inf)



subsection‹Binary union›

lemma small_vunion_set: "small {x. x ∈∘ A ∨ x ∈∘ B}" 
  by (rule down[of _ ‹A ∪∘ B›]) (auto simp: elts_sup_iff)


text‹Rules.›

lemma vunion_def: "A ∪∘ B = set {x. x ∈∘ A ∨ x ∈∘ B}"
  unfolding Un_def sup_V_def by simp

lemma vunion_iff[simp]: "x ∈∘ A ∪∘ B ⟷ x ∈∘ A ∨ x ∈∘ B" 
  by (simp add: elts_sup_iff)

lemma vunionI1:
  assumes "a ∈∘ A"
  shows "a ∈∘ A ∪∘ B"
  using assms by simp

lemma vunionI2:
  assumes "a ∈∘ B"
  shows "a ∈∘ A ∪∘ B"
  using assms by simp

lemma vunionCI[intro!]: 
  assumes "x ∉∘ B ⟹ x ∈∘ A"
  shows "x ∈∘ A ∪∘ B" 
  using assms by clarsimp

lemma vunionE[elim!]: 
  assumes "x ∈∘ A ∪∘ B" and "x ∈∘ A ⟹ P" and "x ∈∘ B ⟹ P" 
  shows P
  using assms by auto


text‹Elementary properties.›

lemma vunion_union: "A ∪∘ B = set (elts A ∪ elts B)" by auto

lemma vunion_assoc: "A ∪∘ (B ∪∘ C) = (A ∪∘ B) ∪∘ C" by auto

lemma vunion_comm: "A ∪∘ B = B ∪∘ A" by auto


text‹Previous set operations.›

lemma vsubset_vunion_left: "(A ∪∘ B) ⊆∘ C ⟷ (A ⊆∘ C ∧ B ⊆∘ C)" by simp

lemma vsubset_vunion_leftD[dest]:
  assumes "(A ∪∘ B) ⊆∘ C"
  shows "A ⊆∘ C" and "B ⊆∘ C"
  using assms by auto

lemma vsubset_vunion_leftI[intro]:
  assumes "A ⊆∘ C" and "B ⊆∘ C"
  shows "(A ∪∘ B) ⊆∘ C"
  using assms by auto

lemma vintersection_vunion_left: "(A ∪∘ B) ∩∘ C = (A ∩∘ C) ∪∘ (B ∩∘ C)"
  by auto

lemma vintersection_vunion_right: "A ∩∘ (B ∪∘ C) = (A ∩∘ B) ∪∘ (A ∩∘ C)"
  by auto


text‹Set operations.›

lemmas vunion_vempty_left = sup_V_0_left 
  and vunion_vempty_right = sup_V_0_right 

lemma vunion_vsingleton[simp]: "set {a} ∪∘ A = vinsert a A" by auto

lemma vunion_vdoubleton[simp]: "set {a, b} ∪∘ A = vinsert a (vinsert b A)" 
  by auto

lemma vunion_vinsert_commutativity_left: 
  "(vinsert a A) ∪∘ B = A ∪∘ (vinsert a B)" 
  by auto

lemma vunion_vinsert_commutativity_right: 
  "A ∪∘ (vinsert a B) = (vinsert a A) ∪∘ B" 
  by auto

lemma vinsert_def: "vinsert y B = set {x. x = y} ∪∘ B" by auto

lemma vunion_vinsert_left: "(vinsert a A) ∪∘ B = vinsert a (A ∪∘ B)" by auto

lemma vunion_vinsert_right: "A ∪∘ (vinsert a B) = vinsert a (A ∪∘ B)" by auto


text‹Special properties.›

lemma vunion_fun_mono: 
  assumes "mono f"
  shows "f A ∪∘ f B ⊆∘ f (A ∪∘ B)"
  using assms by (fact mono_sup)



subsection‹Set difference›

definition vdiff :: "V ⇒ V ⇒ V" (infixl ‹-∘› 65) 
  where "A -∘ B = set {x. x ∈∘ A ∧ x ∉∘ B}"
notation vdiff (infixl "-∘" 65)

lemma small_set_vdiff[simp]: "small {x. x ∈∘ A ∧ x ∉∘ B}" 
  by (rule down[of _ A]) simp


text‹Rules.›

lemma vdiff_iff[simp]: "x ∈∘ A -∘ B ⟷ x ∈∘ A ∧ x ∉∘ B" 
  unfolding vdiff_def by simp

lemma vdiffI[intro!]: 
  assumes "x ∈∘ A" and "x ∉∘ B" 
  shows "x ∈∘ A -∘ B" 
  using assms by simp

lemma vdiffD1: 
  assumes "x ∈∘ A -∘ B"
  shows "x ∈∘ A" 
  using assms by simp

lemma vdiffD2: 
  assumes "x ∈∘ A -∘ B" and "x ∈∘ B" 
  shows P 
  using assms by simp

lemma vdiffE[elim!]: 
  assumes "x ∈∘ A -∘ B" and "⟦ x ∈∘ A; x ∉∘ B ⟧ ⟹ P" 
  shows P 
  using assms by simp


text‹Previous set operations.›

lemma vsubset_vdiff: 
  assumes "A ⊆∘ B -∘ C"
  shows "A ⊆∘ B" 
  using assms by auto

lemma vinsert_vdiff_nin[simp]: 
  assumes "a ∉∘ B"
  shows "vinsert a (A -∘ B) = vinsert a A -∘ B"
  using assms by auto


text‹Set operations.›

lemma vdiff_vempty_left[simp]: "0 -∘ A = 0" by auto

lemma vdiff_vempty_right[simp]: "A -∘ 0 = A" by auto

lemma vdiff_vsingleton_vinsert[simp]: "set {a} -∘ vinsert a A = 0" by auto

lemma vdiff_vsingleton_in[simp]: 
  assumes "a ∈∘ A"
  shows "set {a} -∘ A = 0" 
  using assms by auto

lemma vdiff_vsingleton_nin[simp]: 
  assumes "a ∉∘ A"
  shows "set {a} -∘ A = set {a}" 
  using assms by auto

lemma vdiff_vinsert_vsingleton[simp]: "vinsert a A -∘ set {a} = A -∘ set {a}"
  by auto

lemma vdiff_vsingleton[simp]: 
  assumes "a ∉∘ A"
  shows "A -∘ set {a} = A"
  using assms by auto

lemma vdiff_vsubset: 
  assumes "A ⊆∘ B" and "D ⊆∘ C"
  shows "A -∘ C ⊆∘ B -∘ D"
  using assms by auto

lemma vdiff_vinsert_left_in[simp]: 
  assumes "a ∈∘ B"
  shows "(vinsert a A) -∘ B = A -∘ B"
  using assms by auto

lemma vdiff_vinsert_left_nin: 
  assumes "a ∉∘ B"
  shows "(vinsert a A) -∘ B = vinsert a (A -∘ B)"
  using assms by auto

lemma vdiff_vinsert_right_in: "A -∘ (vinsert a B) = A -∘ B -∘ set {a}" by auto

lemma vdiff_vinsert_right_nin[simp]: 
  assumes "a ∉∘ A"
  shows "A -∘ (vinsert a B) = A -∘ B"
  using assms by auto

lemma vdiff_vintersection_left: "(A ∩∘ B) -∘ C = (A -∘ C) ∩∘ (B -∘ C)" by auto

lemma vdiff_vunion_left: "(A ∪∘ B) -∘ C = (A -∘ C) ∪∘ (B -∘ C)" by auto


text‹Special properties.›

lemma complement_vsubset: "I -∘ J ⊆∘ I" by auto

lemma vintersection_complement: "(I -∘ J) ∩∘ J = 0" by auto

lemma vunion_complement: 
  assumes "J ⊆∘ I"
  shows "I -∘ J ∪∘ J = I"
  using assms by auto


subsection‹Augmenting a set with an element›

lemma vinsert_compr: "vinsert y A = set {x. x = y ∨ x ∈∘ A}"
  unfolding vunion_def vinsert_def by simp_all


text‹Rules.›

lemma vinsert_iff[simp]: "x ∈∘ vinsert y A ⟷ x = y ∨ x ∈∘ A" by simp

lemma vinsertI1: "x ∈∘ vinsert x A" by simp

lemma vinsertI2: 
  assumes "x ∈∘ A"
  shows "x ∈∘ vinsert y A" 
  using assms by simp

lemma vinsertE1[elim!]: 
  assumes "x ∈∘ vinsert y A" and "x = y ⟹ P" and "x ∈∘ A ⟹ P" 
  shows P
  using assms unfolding vinsert_def by auto

lemma vinsertCI[intro!]: 
  assumes "x ∉∘ A ⟹ x = y"
  shows "x ∈∘ vinsert y A" 
  using assms by clarsimp


text‹Elementary properties.›

lemma vinsert_insert: "vinsert a A = set (insert a (elts A))" by auto

lemma vinsert_commutativity: "vinsert a (vinsert b C) = vinsert b (vinsert a C)" 
  by auto

lemma vinsert_ident:
  assumes "x ∉∘ A" and "x ∉∘ B" 
  shows "vinsert x A = vinsert x B ⟷ A = B"
  using assms by force

lemmas vinsert_identD[dest] = vinsert_ident[THEN iffD1, rotated 2]
  and vinsert_identI[intro] = vinsert_ident[THEN iffD2]


text‹Set operations.›

lemma vinsert_vempty: "vinsert a 0 = set {a}" by auto

lemma vinsert_vsingleton: "vinsert a (set {b}) = set {a, b}" by auto

lemma vinsert_vdoubleton: "vinsert a (set {b, c}) = set {a, b, c}" by auto

lemma vinsert_vinsert: "vinsert a (vinsert b C) = set {a, b} ∪∘ C" by auto

lemma vinsert_vunion_left: "vinsert a (A ∪∘ B) = vinsert a A ∪∘ B" by auto

lemma vinsert_vunion_right: "vinsert a (A ∪∘ B) = A ∪∘ vinsert a B" by auto

lemma vinsert_vintersection: "vinsert a (A ∩∘ B) = vinsert a A ∩∘ vinsert a B"
  by auto


text‹Special properties.›

lemma vinsert_set_insert_empty_anyI:
  assumes "P (vinsert a 0)"
  shows "P (set (insert a {}))"  
  using assms by (simp add: vinsert_def)

lemma vinsert_set_insert_anyI:
  assumes "small B" and "P (vinsert a (set (insert b B)))"
  shows "P (set (insert a (insert b B)))"  
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

lemma vinsert_set_insert_eq:
  assumes "small B" 
  shows "set (insert a (insert b B)) = vinsert a (set (insert b B))"
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

lemma vsubset_vinsert: 
  "A ⊆∘ vinsert x B ⟷ (if x ∈∘ A then A -∘ set {x} ⊆∘ B else A ⊆∘ B)"
  by auto

lemma vinsert_obtain_ne:
  assumes "A ≠ 0" 
  obtains a A' where "A = vinsert a A'" and "a ∉∘ A'"
proof-
  from assms mem_not_refl obtain a where "a ∈∘ A" 
    by (auto intro!: vsubset_antisym)
  with ‹a ∈∘ A› have "A = vinsert a (A -∘ set {a})" by auto
  then show ?thesis using that by auto
qed



subsection‹Power set›


text‹Rules.›

lemma VPowI:
  assumes "A ⊆∘ B"
  shows "A ∈∘ VPow B" 
  using assms by simp

lemma VPowD: 
  assumes "A ∈∘ VPow B"
  shows "A ⊆∘ B" 
  using assms by (simp add: Pow_def)

lemma VPowE[elim]:
  assumes "A ∈∘ VPow B" and "A ⊆∘ B ⟹ P"
  shows P
  using assms by auto


text‹Elementary properties.›

lemma VPow_bottom: "0 ∈∘ VPow B" by simp

lemma VPow_top: "A ∈∘ VPow A" by simp


text‹Set operations.›

lemma VPow_vempty[simp]: "VPow 0 = set {0}" by auto

lemma VPow_vsingleton[simp]: "VPow (set {a}) = set {0, set {a}}" 
  by (rule vsubset_antisym; rule vsubsetI) auto

lemma VPow_not_vempty: "VPow A ≠ 0" by auto

lemma VPow_mono: 
  assumes "A ⊆∘ B"
  shows "VPow A ⊆∘ VPow B"
  using assms by simp

lemma VPow_vunion_subset: "VPow A ∪∘ VPow B ⊆∘ VPow (A ∪∘ B)" by simp



subsection‹Singletons, using insert›


text‹Rules.›

lemma vsingletonI[intro!]: "x ∈∘ set {x}" by auto

lemma vsingletonD[dest!]: 
  assumes "y ∈∘ set {x}"
  shows "y = x" 
  using assms by auto

lemma vsingleton_iff: "y ∈∘ set {x} ⟷ y = x" by simp


text‹Previous set operations.›

lemma VPow_vdoubleton[simp]:
  "VPow (set {a, b}) = set {0, set {a}, set {b}, set {a, b}}"   
  by (intro vsubset_antisym vsubsetI) 
    (auto intro!: vsubset_antisym simp: vinsert_set_insert_eq)

lemma vsubset_vinsertI: 
  assumes "A -∘ set {x} ⊆∘ B"
  shows "A ⊆∘ vinsert x B" 
  using assms by auto


text‹Special properties.›

lemma vsingleton_inject:  
  assumes "set {x} = set {y}"
  shows "x = y" 
  using assms by simp

lemma vsingleton_insert_inj_eq[iff]:
  "set {y} = vinsert x A ⟷ x = y ∧ A ⊆∘ set {y}"
  by auto

lemma vsingleton_insert_inj_eq'[iff]: 
  "vinsert x A = set {y} ⟷ x = y ∧ A ⊆∘ set {y}"
  by auto

lemma vsubset_vsingletonD: 
  assumes "A ⊆∘ set {x}"
  shows "A = 0 ∨ A = set {x}" 
  using assms by auto

lemma vsubset_vsingleton_iff: "a ⊆∘ set {x} ⟷ a = 0 ∨ a = set {x}" by auto

lemma vsubset_vdiff_vinsert: "A ⊆∘ B -∘ vinsert x C ⟷ A ⊆∘ B -∘ C ∧ x ∉∘ A"
  by auto

lemma vunion_vsingleton_iff: 
  "A ∪∘ B = set {x} ⟷ 
    A = 0 ∧ B = set {x} ∨ A = set {x} ∧ B = 0 ∨ A = set {x} ∧ B = set {x}"
  by 
    (
      metis 
        vsubset_vsingletonD inf_sup_ord(4) sup.idem sup_V_0_right sup_commute
    )

lemma vsingleton_Un_iff: 
  "set {x} = A ∪∘ B ⟷ 
    A = 0 ∧ B = set {x} ∨ A = set {x} ∧ B = 0 ∨ A = set {x} ∧ B = set {x}"
  by (metis vunion_vsingleton_iff sup_V_0_left sup_V_0_right sup_idem)

lemma VPow_vsingleton_iff[simp]: "VPow X = set {Y} ⟷ X = 0 ∧ Y = 0" 
  by (auto intro!: vsubset_antisym)



subsection‹Intersection of elements›

lemma small_VInter[simp]:
  assumes "A ≠ 0"
  shows "small {a. ∀x ∈∘ A. a ∈∘ x}"
  by (metis (no_types, lifting) assms down eq0_iff mem_Collect_eq subsetI)

lemma VInter_def: "⋂∘ A = (if A = 0 then 0 else set {a. ∀x ∈∘ A. a ∈∘ x})"
proof(cases ‹A = 0›)
  case True show ?thesis unfolding True Inf_V_def by simp
next
  case False 
  from False have "(⋂ (elts ` elts A)) = {a. ∀x ∈∘ A. a ∈∘ x}" by auto
  with False show ?thesis unfolding Inf_V_def by auto
qed


text‹Rules.›

lemma VInter_iff[simp]: 
  assumes [simp]: "A ≠ 0"
  shows "a ∈∘ ⋂∘ A ⟷ (∀x∈∘A. a ∈∘ x)"
  unfolding VInter_def by auto

lemma VInterI[intro]: 
  assumes "A ≠ 0" and "⋀x. x ∈∘ A ⟹ a ∈∘ x"
  shows "a ∈∘ ⋂∘ A"
  using assms by auto

lemma VInter0I[intro]:
  assumes "A = 0"
  shows "⋂∘ A = 0"
  using assms unfolding VInter_def by simp

lemma VInterD[dest]:
  assumes "a ∈∘ ⋂∘ A" and "x ∈∘ A"
  shows "a ∈∘ x"
  using assms by (cases ‹A = 0›) auto

lemma VInterE1[elim]: 
  assumes "a ∈∘ ⋂∘ A" and "x ∉∘ A ⟹ R" and "a ∈∘ x ⟹ R" 
  shows R
  using assms elts_0 unfolding Inter_eq by blast

lemma VInterE2[elim]:
  assumes "a ∈∘ ⋂∘ A" 
  obtains x where "a ∈∘ x" and "x ∈∘ A"
proof(cases ‹A = 0›)
  show "(⋀x. a ∈∘ x ⟹ x ∈∘ A ⟹ thesis) ⟹ A = 0 ⟹ thesis"
    using assms unfolding Inf_V_def by auto
  show "(⋀x. a ∈∘ x ⟹ x ∈∘ A ⟹ thesis) ⟹ A ≠ 0 ⟹ thesis"
    using assms by (meson assms VInterE1 that trad_foundation)
qed

lemma VInterE3: (*not elim*)
  assumes "a ∈∘ ⋂∘ A" and "(⋀y. y ∈∘ A ⟹ a ∈∘ y) ⟹ P"
  shows P
  using assms by auto


text‹Elementary properties.›

lemma VInter_Inter: "⋂∘ A = set (⋂ (elts ` (elts A)))"
  by (simp add: Inf_V_def ext)

lemma VInter_eq:
  assumes [simp]: "A ≠ 0"
  shows "⋂∘ A = set {a. ∀x ∈∘ A. a ∈∘ x}"
  unfolding VInter_def by auto


text‹Set operations.›

lemma VInter_vempty[simp]: "⋂∘ 0 = 0" using VInter0I by auto

lemma VInf_vempty[simp]: "⨅{} = (0::V)" by (simp add: Inf_V_def)

lemma VInter_vdoubleton: "⋂∘ (set {a, b}) = a ∩∘ b"
proof(intro vsubset_antisym vsubsetI)
  show "x ∈∘ ⋂∘ (set {a, b}) ⟹ x ∈∘ a ∩∘ b" for x by (elim VInterE3) auto
  show "x ∈∘ a ∩∘ b ⟹ x ∈∘ ⋂∘ (set {a, b})" for x by (intro VInterI) force+
qed

lemma VInter_antimono: 
  assumes "B ≠ 0" and "B ⊆∘ A"
  shows "⋂∘ A ⊆∘ ⋂∘ B"
  using assms by blast

lemma VInter_vsubset: 
  assumes "⋀x. x ∈∘ A ⟹ x ⊆∘ B" and "A ≠ 0" 
  shows "⋂∘ A ⊆∘ B"
  using assms by auto

lemma VInter_vinsert: 
  assumes "A ≠ 0"
  shows "⋂∘ (vinsert a A) = a ∩∘ ⋂∘ A"
  using assms by (blast intro!: vsubset_antisym)

lemma VInter_vunion: 
  assumes "A ≠ 0" and "B ≠ 0"   
  shows "⋂∘(A ∪∘ B) = ⋂∘A ∩∘ ⋂∘B"
  using assms by (blast intro!: vsubset_antisym)

lemma VInter_vintersection: 
  assumes "A ∩∘ B ≠ 0"
  shows "⋂∘ A ∪∘ ⋂∘ B ⊆∘ ⋂∘ (A ∩∘ B)" 
  using assms by auto

lemma VInter_VPow: "⋂∘ (VPow A) ⊆∘ VPow (⋂∘ A)" by auto


text‹Elementary properties.›

lemma VInter_lower: 
  assumes "x ∈∘ A"
  shows "⋂∘ A ⊆∘ x"
  using assms by auto

lemma VInter_greatest: 
  assumes "A ≠ 0" and "⋀x. x ∈∘ A ⟹ B ⊆∘ x" 
  shows "B ⊆∘ ⋂∘ A"
  using assms by auto



subsection‹Union of elements›

lemma Union_eq_VUnion: "⋃(elts ` elts A) = {a. ∃x ∈∘ A. a ∈∘ x}" by auto

lemma small_VUnion[simp]: "small {a. ∃x ∈∘ A. a ∈∘ x}"
  by (fold Union_eq_VUnion) simp

lemma VUnion_def: "⋃∘A = set {a. ∃x ∈∘ A. a ∈∘ x}"
  unfolding Sup_V_def by auto


text‹Rules.›

lemma VUnion_iff[simp]: "A ∈∘ ⋃∘C ⟷ (∃x∈∘C. A ∈∘ x)" by auto

lemma VUnionI[intro]: 
  assumes "x ∈∘ A" and "a ∈∘ x"
  shows "a ∈∘ ⋃∘A" 
  using assms by auto

lemma VUnionE[elim!]: 
  assumes "a ∈∘ ⋃∘A" and "⋀x. a ∈∘ x ⟹ x ∈∘ A ⟹ R" 
  shows R
  using assms by clarsimp


text‹Elementary properties.›

lemma VUnion_Union: "⋃∘A = set (⋃ (elts ` (elts A)))"
  by (simp add: Inf_V_def ext)


text‹Set operations.›

lemma VUnion_vempty[simp]: "⋃∘0 = 0" by simp

lemma VUnion_vsingleton[simp]: "⋃∘(set {a}) = a" by simp

lemma VUnion_vdoubleton[simp]: "⋃∘(set {a, b}) = a ∪∘ b" by auto

lemma VUnion_mono: 
  assumes "A ⊆∘ B"
  shows "⋃∘A ⊆∘ ⋃∘B" 
  using assms by auto

lemma VUnion_vinsert: "⋃∘(vinsert x A) = x ∪∘ ⋃∘A" by auto

lemma VUnion_vintersection: "⋃∘(A ∩∘ B) ⊆∘ ⋃∘A ∩∘ ⋃∘B" by auto

lemma VUnion_vunion[simp]: "⋃∘(A ∪∘ B) = ⋃∘A ∪∘ ⋃∘B" by auto

lemma VUnion_VPow[simp]: "⋃∘(VPow A) = A" by auto


text‹Special properties.›

lemma VUnion_vempty_conv_left: "0 = ⋃∘A ⟷ (∀x∈∘A. x = 0)" by auto

lemma VUnion_vempty_conv_right: "⋃∘A = 0 ⟷ (∀x∈∘A. x = 0)" by auto

lemma vsubset_VPow_VUnion: "A ⊆∘ VPow (⋃∘A)" by auto

lemma VUnion_vsubsetI: 
  assumes "⋀x. x ∈∘ A ⟹ ∃y. y ∈∘ B ∧ x ⊆∘ y"
  shows "⋃∘A ⊆∘ ⋃∘B"
  using assms by auto

lemma VUnion_upper: 
  assumes "x ∈∘ A"
  shows "x ⊆∘ ⋃∘A" 
  using assms by auto

lemma VUnion_least: 
  assumes "⋀x. x ∈∘ A ⟹ x ⊆∘ B" 
  shows "⋃∘A ⊆∘ B" 
  using assms by (fact Sup_least)



subsection‹Pairs›


subsubsection‹Further results›

lemma small_elts_of_set[simp, intro]:
  assumes "small x"
  shows "elts (set x) = x"
  by (simp add: assms)

lemma small_vpair[intro, simp]:
  assumes "small {a. P a}"
  shows "small {⟨a, b⟩ | a. P a}"
  by (subgoal_tac ‹{⟨a, b⟩ | a. P a} = (λa. ⟨a, b⟩) ` {a. P a}›)
    (auto simp: assms)


subsubsection‹‹vpairs››

definition vpairs :: "V ⇒ V" where
  "vpairs r = set {x. x ∈∘ r ∧ (∃a b. x = ⟨a, b⟩)}"

lemma small_vpairs[simp]: "small {⟨a, b⟩ | a b. ⟨a, b⟩ ∈∘ r}"
  by (rule down[of _ r]) clarsimp


text‹Rules.›

lemma vpairsI[intro]: 
  assumes "x ∈∘ r" and "x = ⟨a, b⟩" 
  shows "x ∈∘ vpairs r"
  using assms unfolding vpairs_def by auto

lemma vpairsD[dest]:
  assumes "x ∈∘ vpairs r" 
  shows "x ∈∘ r" and "∃a b. x = ⟨a, b⟩" 
  using assms unfolding vpairs_def by auto

lemma vpairsE[elim]:
  assumes "x ∈∘ vpairs r"
  obtains a b where "x = ⟨a, b⟩" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vpairs_def by auto

lemma vpairs_iff: "x ∈∘ vpairs r ⟷ x ∈∘ r ∧ (∃a b. x = ⟨a, b⟩)" by auto


text‹Elementary properties.›

lemma vpairs_iff_elts: "⟨a, b⟩ ∈∘ vpairs r ⟷ ⟨a, b⟩ ∈∘ r" by auto

lemma vpairs_iff_pairs: "⟨a, b⟩ ∈∘ vpairs r ⟷ (a, b) ∈ pairs r"
  by (simp add: vpairs_iff_elts pairs_iff_elts)


text‹Set operations.›

lemma vpairs_vempty[simp]: "vpairs 0 = 0" by auto

lemma vpairs_vsingleton[simp]: "vpairs (set {⟨a, b⟩}) = set {⟨a, b⟩}" by auto

lemma vpairs_vinsert: "vpairs (vinsert ⟨a, b⟩ A) = set {⟨a, b⟩} ∪∘ vpairs A" 
  by auto

lemma vpairs_mono:
  assumes "r ⊆∘ s"
  shows "vpairs r ⊆∘ vpairs s"
  using assms by blast

lemma vpairs_vunion: "vpairs (A ∪∘ B) = vpairs A ∪∘ vpairs B" by auto

lemma vpairs_vintersection: "vpairs (A ∩∘ B) = vpairs A ∩∘ vpairs B" by auto

lemma vpairs_vdiff: "vpairs (A -∘ B) = vpairs A -∘ vpairs B" by auto


text‹Special properties.›

lemma vpairs_ex_vfst:
  assumes "x ∈∘ vpairs r"
  shows "∃b. ⟨vfst x, b⟩ ∈∘ r"
  using assms by force

lemma vpairs_ex_vsnd:
  assumes "y ∈∘ vpairs r"
  shows "∃a. ⟨a, vsnd y⟩ ∈∘ r"
  using assms by force



subsection‹Cartesian products›

text‹
The following lemma is based on Theorem 6.2 from 
\cite{takeuti_introduction_1971}.
›

lemma vtimes_vsubset_VPowVPow: "A ×∘ B ⊆∘ VPow (VPow (A ∪∘ B))"
proof(intro vsubsetI)
  fix x assume "x ∈∘ A ×∘ B" 
  then obtain a b where x_def: "x = ⟨a, b⟩" and "a ∈∘ A" and "b ∈∘ B" by clarsimp
  then show "x ∈∘ VPow (VPow (A ∪∘ B))"
    unfolding x_def vpair_def by auto
qed



subsection‹Pairwise›

definition vpairwise :: "(V ⇒ V ⇒ bool) ⇒ V ⇒ bool"
  where "vpairwise R S ⟷ (∀x∈∘S. ∀y∈∘S. x ≠ y ⟶ R x y)"


text‹Rules.›

lemma vpairwiseI[intro?]:
  assumes "⋀x y. x ∈∘ S ⟹ y ∈∘ S ⟹ x ≠ y ⟹ R x y"
  shows "vpairwise R S" 
  using assms by (simp add: vpairwise_def)

lemma vpairwiseD[dest]: 
  assumes "vpairwise R S" and "x ∈∘ S" and "y ∈∘ S" and "x ≠ y"
  shows "R x y" and "R y x"
  using assms unfolding vpairwise_def by auto


text‹Elementary properties.›

lemma vpairwise_trivial[simp]: "vpairwise (λi j. j ≠ i) I"
  by (auto simp: vpairwise_def)


text‹Set operations.›

lemma vpairwise_vempty[simp]: "vpairwise P 0" by (force intro: vpairwiseI)

lemma vpairwise_vsingleton[simp]: "vpairwise P (set {A})"
  by (simp add: vpairwise_def)

lemma vpairwise_vinsert:
  "vpairwise r (vinsert x s) ⟷ 
    (∀y. y ∈∘ s ∧ y ≠ x ⟶ r x y ∧ r y x) ∧ vpairwise r s"
  by (intro iffI conjI allI impI; (elim conjE | tactic‹all_tac›))
    (auto simp: vpairwise_def)

lemma vpairwise_vsubset: 
  assumes "vpairwise P S" and "T ⊆∘ S" 
  shows "vpairwise P T"
  using assms by (metis less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)

lemma vpairwise_mono: 
  assumes "vpairwise P A" and "⋀x y. P x y ⟹ Q x y" and "B ⊆∘ A" 
  shows "vpairwise Q B"
  using assms by (simp add: less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)



subsection‹Disjoint sets›

abbreviation vdisjnt :: "V ⇒ V ⇒ bool"
  where "vdisjnt A B ≡ A ∩∘ B = 0"


text‹Elementary properties.›

lemma vdisjnt_sym: 
  assumes "vdisjnt A B"
  shows "vdisjnt B A"
  using assms by blast

lemma vdisjnt_iff: "vdisjnt A B ⟷ (∀x. ~ (x ∈∘ A ∧ x ∈∘ B))" by auto


text‹Set operations.›

lemma vdisjnt_vempty1[simp]: "vdisjnt 0 A"
  and vdisjnt_vempty2[simp]: "vdisjnt A 0"
  by auto

lemma vdisjnt_singleton0[simp]: "vdisjnt (set {a}) (set {b}) ⟷ a ≠ b"
  and vdisjnt_singleton1[simp]: "vdisjnt (set {a}) A ⟷ a ∉∘ A"
  and vdisjnt_singleton2[simp]: "vdisjnt A (set {a}) ⟷ a ∉∘ A"
  by force+

lemma vdisjnt_vinsert_left: "vdisjnt (vinsert a X) Y ⟷ a ∉∘ Y ∧ vdisjnt X Y"
  by (metis vdisjnt_iff vdisjnt_sym vinsertE1 vinsertI2 vinsert_iff)

lemma vdisjnt_vinsert_right: "vdisjnt Y (vinsert a X) ⟷ a ∉∘ Y ∧ vdisjnt Y X"
  using vdisjnt_sym vdisjnt_vinsert_left by meson

lemma vdisjnt_vsubset_left: 
  assumes "vdisjnt X Y" and "Z ⊆∘ X" 
  shows "vdisjnt Z Y"
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_vsubset_right: 
  assumes "vdisjnt X Y" and "Z ⊆∘ Y"
  shows "vdisjnt X Z"
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_vunion_left: "vdisjnt (A ∪∘ B) C ⟷ vdisjnt A C ∧ vdisjnt B C"
  by auto

lemma vdisjnt_vunion_right: "vdisjnt C (A ∪∘ B) ⟷ vdisjnt C A ∧ vdisjnt C B"
  by auto


text‹Special properties.›

lemma vdisjnt_vemptyI[intro]:
  assumes "⋀x. x ∈∘ A ⟹ x ∈∘ B ⟹ False"
  shows "vdisjnt A B" 
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_self_iff_vempty[simp]: "vdisjnt S S ⟷ S = 0" by auto

lemma vdisjntI:
  assumes "⋀x y. x ∈∘ A ⟹ y ∈∘ B ⟹ x ≠ y"
  shows "vdisjnt A B"
  using assms by auto

lemma vdisjnt_nin_right:
  assumes "vdisjnt A B" and "a ∈∘ A"
  shows "a ∉∘ B"
  using assms by auto

lemma vdisjnt_nin_left:
  assumes "vdisjnt B A" and "a ∈∘ A"
  shows "a ∉∘ B"
  using assms by auto

text‹\newpage›

end

Theory CZH_Sets_Nat

(* Copyright 2021 (C) Mihails Milehins *)

section‹Further properties of natural numbers›
theory CZH_Sets_Nat
  imports CZH_Sets_Sets
begin



subsection‹Background›


text‹
The section exposes certain fundamental properties of natural numbers and
provides convenience utilities for doing arithmetic within the type typ‹V›. 

Many of the results that are presented in this sections were carried over
(with amendments) from the theory ‹Nat› that can be found in the main 
library of Isabelle/HOL. 
›

notation ord_of_nat (‹_ℕ› [999] 999)

named_theorems nat_omega_simps

declare One_nat_def[simp del]

abbreviation (input) vpfst where "vpfst a ≡ a⦇0⦈"
abbreviation (input) vpsnd where "vpsnd a ≡ a⦇1ℕ⦈"
abbreviation (input) vpthrd where "vpthrd a ≡ a⦇2ℕ⦈"



subsection‹Conversion between typ‹V› and ‹nat››


subsubsection‹Primitive arithmetic›

lemma ord_of_nat_plus[nat_omega_simps]: "aℕ + bℕ = (a + b)ℕ"
  by (induct b) (simp_all add: plus_V_succ_right)

lemma ord_of_nat_times[nat_omega_simps]: "aℕ * bℕ = (a * b)ℕ"
  by (induct b) (simp_all add: mult_succ nat_omega_simps)

lemma ord_of_nat_succ[nat_omega_simps]: "succ (aℕ) = (Suc a)ℕ" by auto

lemmas [nat_omega_simps] = nat_cadd_eq_add

lemma ord_of_nat_csucc[nat_omega_simps]: "csucc (aℕ) = succ (aℕ)" 
  using finite_csucc by blast

lemma ord_of_nat_succ_vempty[nat_omega_simps]: "succ 0 = 1ℕ" by auto

lemma ord_of_nat_vone[nat_omega_simps]: "1 = 1ℕ" by auto


subsubsection‹Transfer›

definition cr_omega :: "V ⇒ nat ⇒ bool"
  where "cr_omega a b ⟷ (a = ord_of_nat b)"


text‹Transfer setup.›

lemma cr_omega_right_total[transfer_rule]: "right_total cr_omega"
  unfolding cr_omega_def right_total_def by simp

lemma cr_omega_bi_unqie[transfer_rule]: "bi_unique cr_omega"
  unfolding cr_omega_def bi_unique_def
  by (simp add: inj_eq inj_ord_of_nat)

lemma omega_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_omega = (λx. x ∈∘ ω)"
  unfolding cr_omega_def by (auto simp: elts_ω)

lemma omega_transfer[transfer_rule]: 
  "(rel_set cr_omega) (elts ω) (UNIV::nat set)"
  unfolding cr_omega_def rel_set_def by (simp add: elts_ω)

lemma omega_of_real_transfer[transfer_rule]: "cr_omega (ord_of_nat a) a"
  unfolding cr_omega_def by auto


text‹Operations.›

lemma omega_succ_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_omega ===> cr_omega) succ Suc"
proof(intro rel_funI, unfold cr_omega_def)
  fix x y assume prems: "x = yℕ"
  show "succ x = Suc yℕ" unfolding prems ord_of_nat_succ[symmetric] ..
qed

lemma omega_plus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_omega ===> cr_omega ===> cr_omega) (+) (+)"
  by (intro rel_funI, unfold cr_omega_def) (simp add: nat_omega_simps)

lemma omega_mult_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_omega ===> cr_omega ===> cr_omega) (*) (*)"
  by (intro rel_funI, unfold cr_omega_def) (simp add: nat_omega_simps)

lemma ord_of_nat_card_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(rel_set (=) ===> cr_omega) (λx. ord_of_nat (card x)) card"
  by (intro rel_funI) (simp add: cr_omega_def rel_set_eq)



subsection‹Elementary results›

lemma ord_of_nat_vempty: "0 = 0ℕ" by auto

lemma set_vzero_eq_ord_of_nat_vone: "set {0} = 1ℕ"
  by (metis elts_1 set_of_elts ord_of_nat_vone)

lemma vone_in_omega[simp]: "1 ∈∘ ω" unfolding ω_def by force

lemma nat_of_omega:
  assumes "n ∈∘ ω" 
  obtains m where "n = mℕ"
  using assms unfolding ω_def by clarsimp

lemma omega_prev:
  assumes "n ∈∘ ω" and "0 ∈∘ n"
  obtains k where "n = succ k"
proof-
  from assms nat_of_omega obtain m where "n = mℕ" by auto
  with assms(2) obtain m' where "m = Suc m'"
    unfolding less_V_def by (auto dest: gr0_implies_Suc)
  with that show ?thesis unfolding ‹n = mℕ› using ord_of_nat.simps(2) by blast  
qed

lemma omega_vplus_commutative:
  assumes "a ∈∘ ω" and "b ∈∘ ω" 
  shows "a + b = b + a" 
  using assms by (metis Groups.add_ac(2) nat_of_omega ord_of_nat_plus)

lemma omega_vinetrsection[intro]:
  assumes "m ∈∘ ω" and "n ∈∘ ω"
  shows "m ∩∘ n ∈∘ ω"
proof-
  from nat_into_Ord[OF assms(1)] nat_into_Ord[OF assms(2)] Ord_linear_le 
  consider "m ⊆∘ n" | "n ⊆∘ m" 
    by auto
  then show ?thesis by cases (simp_all add: assms inf.absorb1 inf.absorb2)
qed



subsection‹Induction›

lemma omega_induct_all[consumes 1, case_names step]:
  assumes "n ∈∘ ω" and "⋀x. ⟦x ∈∘ ω; ⋀y. y ∈∘ x ⟹ P y⟧ ⟹ P x" 
  shows "P n"
  using assms by (metis Ord_ω Ord_induct Ord_linear Ord_trans nat_into_Ord)

lemma omega_induct[consumes 1, case_names 0 succ]:
  assumes "n ∈∘ ω" and "P 0" and "⋀n. ⟦ n ∈∘ ω; P n ⟧ ⟹ P (succ n)" 
  shows "P n"
  using assms(1,3)
proof(induct rule: omega_induct_all)
  case (step x) show ?case
  proof(cases ‹x = 0›)
    case True with assms(2) show ?thesis by simp
  next
    case False
    with step(1) have "0 ∈∘ x" by (simp add: mem_0_Ord)
    with ‹x ∈∘ ω› obtain y where x_def: "x = succ y" by (elim omega_prev)
    with elts_succ step.hyps(1) have "y ∈∘ ω" by (blast intro: Ord_trans)
    have "y ∈∘ x" by (simp add: ‹x = succ y›) 
    have "P y" by (auto intro: step.prems step.hyps(2)[OF ‹y ∈∘ x›])
    from step.prems[OF ‹y ∈∘ ω› ‹P y›, folded x_def] show "P x" . 
  qed
qed



subsection‹Methods›


text‹
The following methods provide an infrastructure for working with goals of the 
form ‹a ∈∘ nℕ ⟹ P a›.
›

lemma in_succE:
  assumes "a ∈∘ succ n" and "⋀a. a ∈∘ n ⟹ P a" and "P n"
  shows "P a"
  using assms by auto

method Suc_of_numeral =
  (
    unfold numeral.simps add.assoc,
    use nothing in ‹unfold Suc_eq_plus1_left[symmetric], unfold One_nat_def›
  )

method succ_of_numeral = 
  (
    Suc_of_numeral, 
    use nothing in ‹unfold ord_of_nat_succ[symmetric] ord_of_nat_zero›
  )

method numeral_of_succ =
  (
    unfold nat_omega_simps, 
    use nothing in 
      ‹
        unfold numeral.simps[symmetric] Suc_numeral add_num_simps,
        (unfold numerals(1))?
      ›
  )

method elim_in_succ =
  (
    (
      elim in_succE; 
      use nothing in ‹(unfold triv_forall_equality)?; (numeral_of_succ)?›
    ), 
    simp
  )

method elim_in_numeral = (succ_of_numeral, use nothing in ‹elim_in_succ›)



subsection‹Auxiliary›

lemma two: "2ℕ = set {0, 1ℕ}" by force

lemma three: "3ℕ = set {0, 1ℕ, 2ℕ}" by force

lemma four: "4ℕ = set {0, 1ℕ, 2ℕ, 3ℕ}" by force

lemma two_vdiff_zero[simp]: "set {0, 1ℕ} -∘ set {0} = set {1ℕ}" by auto
lemma two_vdiff_one[simp]: "set {0, 1ℕ} -∘ set {1ℕ} = set {0}" by auto


text‹\newpage›

end

Theory CZH_Sets_BRelations

(* Copyright 2021 (C) Mihails Milehins *)

section‹Elementary binary relations›
theory CZH_Sets_BRelations
  imports CZH_Sets_Sets
  keywords "mk_VLambda" :: thy_defn  
    and "|app" "|vsv" "|vdomain" 
begin



subsection‹Background›


text‹
This section presents a theory of binary relations internalized in the 
type typ‹V› and exposes elementary properties of two special types of 
binary relations: single-valued binary relations and injective single-valued 
binary relations.

Many of the results that are presented in this section were carried over
(with amendments) from the theories text‹Set› and text‹Relation› in the main
library.
›



subsection‹Constructors›


subsubsection‹Identity relation›

definition vid_on :: "V ⇒ V"
  where "vid_on A = set {⟨a, a⟩ | a. a ∈∘ A}"

lemma vid_on_small[simp]: "small {⟨a, a⟩ | a. a ∈∘ A}"
  by (rule down[of _ ‹A ×∘ A›]) blast


text‹Rules.›

lemma vid_on_eqI: 
  assumes "a = b" and "a ∈∘ A"
  shows "⟨a, b⟩ ∈∘ vid_on A"
  using assms by (simp add: vid_on_def)

lemma vid_onI[intro!]: 
  assumes "a ∈∘ A"
  shows "⟨a, a⟩ ∈∘ vid_on A"
  by (rule vid_on_eqI) (simp_all add: assms)

lemma vid_onD[dest!]: 
  assumes "⟨a, a⟩ ∈∘ vid_on A"
  shows "a ∈∘ A"
  using assms unfolding vid_on_def by auto

lemma vid_onE[elim!]: 
  assumes "x ∈∘ vid_on A" and "∃a∈∘A. x = ⟨a, a⟩ ⟹ P" 
  shows P
  using assms unfolding vid_on_def by auto

lemma vid_on_iff: "⟨a, b⟩ ∈∘ vid_on A ⟷ a = b ∧ a ∈∘ A" by auto


text‹Set operations.›

lemma vid_on_vempty[simp]: "vid_on 0 = 0" by auto

lemma vid_on_vsingleton[simp]: "vid_on (set {a}) = set {⟨a, a⟩}" by auto

lemma vid_on_vdoubleton[simp]: "vid_on (set {a, b}) = set {⟨a, a⟩, ⟨b, b⟩}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vid_on_mono: 
  assumes "A ⊆∘ B"
  shows "vid_on A ⊆∘ vid_on B"
  using assms by auto

lemma vid_on_vinsert: "(vinsert ⟨a, a⟩ (vid_on A)) = (vid_on (vinsert a A))" 
  by auto

lemma vid_on_vintersection: "vid_on (A ∩∘ B) = vid_on A ∩∘ vid_on B" by auto

lemma vid_on_vunion: "vid_on (A ∪∘ B) = vid_on A ∪∘ vid_on B" by auto

lemma vid_on_vdiff: "vid_on (A -∘ B) = vid_on A -∘ vid_on B" by auto


text‹Special properties.›

lemma vid_on_vsubset_vtimes: "vid_on A ⊆∘ A ×∘ A" by clarsimp


subsubsection‹Constant function›

definition vconst_on :: "V ⇒ V ⇒ V"
  where "vconst_on A c = set {⟨a, c⟩ | a. a ∈∘ A}"

lemma small_vconst_on[simp]: "small {⟨a, c⟩ | a. a ∈∘ A}"
  by (rule down[of _ ‹A ×∘ set {c}›]) auto


text‹Rules.›

lemma vconst_onI[intro!]: 
  assumes "a ∈∘ A"
  shows "⟨a, c⟩ ∈∘ vconst_on A c"
  using assms unfolding vconst_on_def by simp

lemma vconst_onD[dest!]: 
  assumes "⟨a, c⟩ ∈∘ vconst_on A c"
  shows "a ∈∘ A" 
  using assms unfolding vconst_on_def by simp

lemma vconst_onE[elim!]: 
  assumes "x ∈∘ vconst_on A c"
  obtains a where "a ∈∘ A" and "x = ⟨a, c⟩"
  using assms unfolding vconst_on_def by auto

lemma vconst_on_iff: "⟨a, c⟩ ∈∘ vconst_on A c ⟷ a ∈∘ A" by auto


text‹Set operations.›

lemma vconst_on_vempty[simp]: "vconst_on 0 c = 0"
  unfolding vconst_on_def by auto

lemma vconst_on_vsingleton[simp]: "vconst_on (set {a}) c = set {⟨a, c⟩}" by auto

lemma vconst_on_vdoubleton[simp]: "vconst_on (set {a, b}) c = set {⟨a, c⟩, ⟨b, c⟩}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vconst_on_mono: 
  assumes "A ⊆∘ B"
  shows "vconst_on A c ⊆∘ vconst_on B c"
  using assms by auto

lemma vconst_on_vinsert:
  "(vinsert ⟨a, c⟩ (vconst_on A c)) = (vconst_on (vinsert a A) c)" 
  by auto

lemma vconst_on_vintersection: 
  "vconst_on (A ∩∘ B) c = vconst_on A c ∩∘ vconst_on B c"
  by auto

lemma vconst_on_vunion: "vconst_on (A ∪∘ B) c = vconst_on A c ∪∘ vconst_on B c"
  by auto

lemma vconst_on_vdiff: "vconst_on (A -∘ B) c = vconst_on A c -∘ vconst_on B c"
  by auto


text‹Special properties.›

lemma vconst_on_eq_vtimes: "vconst_on A c = A ×∘ set {c}" 
  by standard (auto intro!: vsubset_antisym)


subsubsection‹‹VLambda››


text‹Rules.›

lemma VLambdaI[intro!]: 
  assumes "a ∈∘ A"
  shows "⟨a, f a⟩ ∈∘ (λa∈∘A. f a)"
  using assms unfolding VLambda_def by auto

lemma VLambdaD[dest!]: 
  assumes "⟨a, f a⟩ ∈∘ (λa∈∘A. f a)"
  shows "a ∈∘ A"
  using assms unfolding VLambda_def by auto

lemma VLambdaE[elim!]:  
  assumes "x ∈∘ (λa∈∘A. f a)"
  obtains a where "a ∈∘ A" and "x = ⟨a, f a⟩"
  using assms unfolding VLambda_def by auto

lemma VLambda_iff1: "x ∈∘ (λa∈∘A. f a) ⟷ (∃a∈∘A. x = ⟨a, f a⟩)" by auto

lemma VLambda_iff2: "⟨a, b⟩ ∈∘ (λa∈∘A. f a) ⟷ b = f a ∧ a ∈∘ A" by auto

lemma small_VLambda[simp]: "small {⟨a, f a⟩ | a. a ∈∘ A}" by auto

lemma VLambda_set_def: "(λa∈∘A. f a) = set {⟨a, f a⟩ | a. a ∈∘ A}" by auto


text‹Set operations.›

lemma VLambda_vempty[simp]: "(λa∈∘0. f a) = 0" by auto

lemma VLambda_vsingleton(*not simp*): "(λa∈∘set {a}. f a) = set {⟨a, f a⟩}" 
  by auto

lemma VLambda_vdoubleton(*not simp*): 
  "(λa∈∘set {a, b}. f a) = set {⟨a, f a⟩, ⟨b, f b⟩}"
  by (auto simp: vinsert_set_insert_eq)

lemma VLambda_mono: 
  assumes "A ⊆∘ B"
  shows "(λa∈∘A. f a) ⊆∘ (λa∈∘B. f a)"
  using assms by auto

lemma VLambda_vinsert: 
  "(λa∈∘vinsert a A. f a) = (λa∈∘set {a}. f a) ∪∘ (λa∈∘A. f a)" 
  by auto

lemma VLambda_vintersection: "(λa∈∘A ∩∘ B. f a) = (λa∈∘A. f a) ∩∘ (λa∈∘B. f a)" 
  by auto

lemma VLambda_vunion: "(λa∈∘A ∪∘ B. f a) = (λa∈∘A. f a) ∪∘ (λa∈∘B. f a)" by auto

lemma VLambda_vdiff: "(λa∈∘A -∘ B. f a) = (λa∈∘A. f a) -∘ (λa∈∘B. f a)" by auto


text‹Connections.›

lemma VLambda_vid_on: "(λa∈∘A. a) = vid_on A" by auto

lemma VLambda_vconst_on: "(λa∈∘A. c) = vconst_on A c" by auto


subsubsection‹Composition›

definition vcomp :: "V ⇒ V ⇒ V" (infixr "∘∘" 75)
  where "r ∘∘ s = set {⟨a, c⟩ | a c. ∃b. ⟨a, b⟩ ∈∘ s ∧ ⟨b, c⟩ ∈∘ r}"
notation vcomp (infixr ‹∘∘› 75)

lemma vcomp_small[simp]: "small {⟨a, c⟩ | a c. ∃b. ⟨a, b⟩ ∈∘ s ∧ ⟨b, c⟩ ∈∘ r}" 
  (is ‹small ?s›)
proof-
  define comp' where "comp' = (λ⟨⟨a, b⟩, ⟨c, d⟩⟩. ⟨a, d⟩)"
  have "small (elts (vpairs (s ×∘ r)))" by simp
  then have small_comp: "small (comp' ` elts (vpairs (s ×∘ r)))" by simp
  have ss: "?s ⊆ (comp' ` elts (vpairs (s ×∘ r)))" 
  proof
    fix x assume "x ∈ ?s"
    then obtain a b c where x_def: "x = ⟨a, c⟩" 
      and "⟨a, b⟩ ∈∘ s" 
      and "⟨b, c⟩ ∈∘ r"
      by auto
    then have abbc: "⟨⟨a, b⟩, ⟨b, c⟩⟩ ∈∘ vpairs (s ×∘ r)"
      by (simp add: vpairs_iff_elts)
    have x_def': "x = comp' ⟨⟨a, b⟩, ⟨b, c⟩⟩" unfolding comp'_def x_def by auto
    then show "x ∈ comp' ` elts (vpairs (s ×∘ r))"
      unfolding x_def' using abbc by auto
  qed
  with small_comp show ?thesis by (metis (lifting) smaller_than_small)
qed


text‹Rules.›

lemma vcompI[intro!]: 
  assumes "⟨b, c⟩ ∈∘ r" and "⟨a, b⟩ ∈∘ s" 
  shows "⟨a, c⟩ ∈∘ r ∘∘ s"
  using assms unfolding vcomp_def by auto

lemma vcompD[dest!]: 
  assumes "⟨a, c⟩ ∈∘ r ∘∘ s"
  shows "∃b. ⟨b, c⟩ ∈∘ r ∧ ⟨a, b⟩ ∈∘ s" 
  using assms unfolding vcomp_def by auto

lemma vcompE[elim!]:
  assumes "ac ∈∘ r ∘∘ s" 
  obtains a b c where "ac = ⟨a, c⟩" and "⟨a, b⟩ ∈∘ s" and "⟨b, c⟩ ∈∘ r"
  using assms unfolding vcomp_def by clarsimp


text‹Elementary properties.›

lemma vcomp_assoc: "(r ∘∘ s) ∘∘ t = r ∘∘ (s ∘∘ t)" by auto


text‹Set operations.›

lemma vcomp_vempty_left[simp]: "0 ∘∘ r = 0" by auto

lemma vcomp_vempty_right[simp]: "r ∘∘ 0 = 0" by auto

lemma vcomp_mono:
  assumes "r' ⊆∘ r" and "s' ⊆∘ s" 
  shows "r' ∘∘ s' ⊆∘ r ∘∘ s"
  using assms by auto

lemma vcomp_vinsert_left[simp]: 
  "(vinsert ⟨a, b⟩ s) ∘∘ r = (set {⟨a, b⟩} ∘∘ r) ∪∘ (s ∘∘ r)" 
  by auto

lemma vcomp_vinsert_right[simp]: 
  "r ∘∘ (vinsert ⟨a, b⟩ s) = (r ∘∘ set {⟨a, b⟩}) ∪∘ (r ∘∘ s)"
  by auto

lemma vcomp_vunion_left[simp]: "(s ∪∘ t) ∘∘ r = (s ∘∘ r) ∪∘ (t ∘∘ r)" by auto

lemma vcomp_vunion_right[simp]: "r ∘∘ (s ∪∘ t) = (r ∘∘ s) ∪∘ (r ∘∘ t)" by auto


text‹Connections.›

lemma vcomp_vid_on_idem[simp]: "vid_on A ∘∘ vid_on A = vid_on A" by auto

lemma vcomp_vid_on[simp]: "vid_on A ∘∘ vid_on B = vid_on (A ∩∘ B)" by auto

lemma vcomp_vconst_on_vid_on[simp]: "vconst_on A c ∘∘ vid_on A = vconst_on A c" 
  by auto

lemma vcomp_VLambda_vid_on[simp]: "(λa∈∘A. f a) ∘∘ vid_on A = (λa∈∘A. f a)" 
  by auto


text‹Special properties.›

lemma vcomp_vsubset_vtimes:
  assumes "r ⊆∘ B ×∘ C" and "s ⊆∘ A ×∘ B" 
  shows "r ∘∘ s ⊆∘ A ×∘ C"
  using assms by auto

lemma vcomp_obtain_middle[elim]:
  assumes "⟨a, c⟩ ∈∘ r ∘∘ s"
  obtains b where "⟨a, b⟩ ∈∘ s" and "⟨b, c⟩ ∈∘ r"
  using assms by auto


subsubsection‹Converse relation›

definition vconverse :: "V ⇒ V"
  where "vconverse A = (λr∈∘A. set {⟨b, a⟩ | a b. ⟨a, b⟩ ∈∘ r})"

abbreviation app_vconverse (‹(_¯∘)› [1000] 999)
  where "r¯∘ ≡ vconverse (set {r}) ⦇r⦈"

lemma app_vconverse_def: "r¯∘ = set {⟨b, a⟩ | a b. ⟨a, b⟩ ∈∘ r}"
  unfolding vconverse_def by simp

lemma vconverse_small[simp]: "small {⟨b, a⟩ | a b. ⟨a, b⟩ ∈∘ r}"
proof-
  have eq: "{⟨b, a⟩ | a b. ⟨a, b⟩ ∈∘ r} = (λ⟨a, b⟩. ⟨b, a⟩) ` elts (vpairs r)"
  proof(rule subset_antisym; rule subsetI, unfold mem_Collect_eq)
    fix x assume "x ∈ (λ⟨a, b⟩. ⟨b, a⟩) ` elts (vpairs r)" 
    then obtain a b where "⟨a, b⟩ ∈∘ vpairs r" and "x = (λ⟨a, b⟩. ⟨b, a⟩) ⟨a, b⟩"
      by blast
    then show "∃a b. x = ⟨b, a⟩ ∧ ⟨a, b⟩ ∈∘ r" by auto
  qed (use image_iff vpairs_iff_elts in fastforce)
  show ?thesis unfolding eq by (rule replacement) auto
qed


text‹Rules.›

lemma vconverseI[intro!]: 
  assumes "r ∈∘ A"
  shows "⟨r, r¯∘⟩ ∈∘ vconverse A"
  using assms unfolding vconverse_def by auto

lemma vconverseD[dest]: 
  assumes "⟨r, s⟩ ∈∘ vconverse A" 
  shows "r ∈∘ A" and "s = r¯∘"
  using assms unfolding vconverse_def by auto

lemma vconverseE[elim]: 
  assumes "x ∈∘ vconverse A" 
  obtains r where "x = ⟨r, r¯∘⟩" and "r ∈∘ A"
  using assms unfolding vconverse_def by auto

lemma app_vconverseI[sym, intro!]: 
  assumes "⟨a, b⟩ ∈∘ r"
  shows "⟨b, a⟩ ∈∘ r¯∘"
  using assms unfolding vconverse_def by auto

lemma app_vconverseD[sym, dest]: 
  assumes "⟨a, b⟩ ∈∘ r¯∘"
  shows "⟨b, a⟩ ∈∘ r" 
  using assms unfolding vconverse_def by simp

lemma app_vconverseE[elim!]: 
  assumes "x ∈∘ r¯∘" 
  obtains a b where "x = ⟨b, a⟩" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vconverse_def by auto

lemma vconverse_iff: "⟨b, a⟩ ∈∘ r¯∘ ⟷ ⟨a, b⟩ ∈∘ r" by auto


text‹Set operations.›

lemma vconverse_vempty[simp]: "0¯∘ = 0" by auto

lemma vconverse_vsingleton: "(set {⟨a, b⟩})¯∘ = set {⟨b, a⟩}" by auto

lemma vconverse_vdoubleton[simp]: "(set {⟨a, b⟩, ⟨c, d⟩})¯∘ = set {⟨b, a⟩, ⟨d, c⟩}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vconverse_vinsert: "(vinsert ⟨a, b⟩ r)¯∘ = vinsert ⟨b, a⟩ (r¯∘)" by auto

lemma vconverse_vintersection: "(r ∩∘ s)¯∘ = r¯∘ ∩∘ s¯∘" by auto

lemma vconverse_vunion: "(r ∪∘ s)¯∘ = r¯∘ ∪∘ s¯∘" by auto


text‹Connections.›

lemma vconverse_vid_on[simp]: "(vid_on A)¯∘ = vid_on A" by auto

lemma vconverse_vconst_on[simp]: "(vconst_on A c)¯∘ = set {c} ×∘ A" by auto

lemma vconverse_vcomp: "(r ∘∘ s)¯∘ = s¯∘ ∘∘ r¯∘" by auto

lemma vconverse_vtimes: "(A ×∘ B)¯∘ = (B ×∘ A)" by auto


subsubsection‹Left restriction›

definition vlrestriction :: "V ⇒ V"
  where "vlrestriction D =
    VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. a ∈∘ A ∧ ⟨a, b⟩ ∈∘ r})"

abbreviation app_vlrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾l∘› 80)
  where "r ↾l∘ A ≡ vlrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"

lemma app_vlrestriction_def: "r ↾l∘ A = set {⟨a, b⟩ | a b. a ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  unfolding vlrestriction_def by simp

lemma vlrestriction_small[simp]: "small {⟨a, b⟩ | a b. a ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma vlrestrictionI[intro!]: 
  assumes "⟨r, A⟩ ∈∘ D"
  shows "⟨⟨r, A⟩, r ↾l∘ A⟩ ∈∘ vlrestriction D"
  using assms unfolding vlrestriction_def by (simp add: VLambda_iff2)

lemma vlrestrictionD[dest]: 
  assumes "⟨⟨r, A⟩, s⟩ ∈∘ vlrestriction D" 
  shows "⟨r, A⟩ ∈∘ D" and "s = r ↾l∘ A"
  using assms unfolding vlrestriction_def by auto

lemma vlrestrictionE[elim]: 
  assumes "x ∈∘ vlrestriction D" and "D ⊆∘ R ×∘ X"
  obtains r A where "x = ⟨⟨r, A⟩, r ↾l∘ A⟩" and "r ∈∘ R" and "A ∈∘ X"
  using assms unfolding vlrestriction_def by auto

lemma app_vlrestrictionI[intro!]: 
  assumes "a ∈∘ A" and "⟨a, b⟩ ∈∘ r" 
  shows "⟨a, b⟩ ∈∘ r ↾l∘ A" 
  using assms unfolding vlrestriction_def by simp

lemma app_vlrestrictionD[dest]: 
  assumes "⟨a, b⟩ ∈∘ r ↾l∘ A"  
  shows "a ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vlrestriction_def by auto

lemma app_vlrestrictionE[elim]: 
  assumes "x ∈∘ r ↾l∘ A"
  obtains a b where "x = ⟨a, b⟩" and "a ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vlrestriction_def by auto


text‹Set operations.›

lemma vlrestriction_on_vempty[simp]: "r ↾l∘ 0 = 0" 
  by (auto intro!: vsubset_antisym)

lemma vlrestriction_vempty[simp]: "0 ↾l∘ A = 0" by auto

lemma vlrestriction_vsingleton_in[simp]: 
  assumes "a ∈∘ A"
  shows "set {⟨a, b⟩} ↾l∘ A = set {⟨a, b⟩}" 
  using assms by auto

lemma vlrestriction_vsingleton_nin[simp]: 
  assumes "a ∉∘ A"
  shows "set {⟨a, b⟩} ↾l∘ A = 0" 
  using assms by auto

lemma vlrestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾l∘ A ⊆∘ r ↾l∘ B"
  using assms by auto

lemma vlrestriction_vinsert_nin[simp]: 
  assumes "a ∉∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾l∘ A = r ↾l∘ A" 
  using assms by auto

lemma vlrestriction_vinsert_in: 
  assumes "a ∈∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾l∘ A = vinsert ⟨a, b⟩ (r ↾l∘ A)" 
  using assms by auto

lemma vlrestriction_vintersection: "(r ∩∘ s) ↾l∘ A = r ↾l∘ A ∩∘ s ↾l∘ A" by auto

lemma vlrestriction_vunion: "(r ∪∘ s) ↾l∘ A = r ↾l∘ A ∪∘ s ↾l∘ A" by auto

lemma vlrestriction_vdiff: "(r -∘ s) ↾l∘ A = r ↾l∘ A -∘ s ↾l∘ A" by auto


text‹Connections.›

lemma vlrestriction_vid_on[simp]: "(vid_on A) ↾l∘ B = vid_on (A ∩∘ B)" by auto

lemma vlrestriction_vconst_on: "(vconst_on A c) ↾l∘ B = (vconst_on B c) ↾l∘ A"
  by auto

lemma vlrestriction_vconst_on_commute:
  assumes "x ∈∘ vconst_on A c ↾l∘ B"
  shows "x ∈∘ vconst_on B c ↾l∘ A"
  using assms by auto

lemma vlrestriction_vcomp[simp]: "(r ∘∘ s) ↾l∘ A = r ∘∘ (s ↾l∘ A)" by auto


text‹Previous connections.›

lemma vcomp_rel_vid_on[simp]: "r ∘∘ vid_on A = r ↾l∘ A" by auto

lemma vcomp_vconst_on: 
  "r ∘∘ (vconst_on A c) = (r ↾l∘ set {c}) ∘∘ (vconst_on A c)" 
  by auto


text‹Special properties.›

lemma vlrestriction_vsubset_vpairs: "r ↾l∘ A ⊆∘ vpairs r"
  by (rule vsubsetI) blast

lemma vlrestriction_vsubset_rel: "r ↾l∘ A ⊆∘ r" by auto

lemma vlrestriction_VLambda: "(λa∈∘A. f a) ↾l∘ B = (λa∈∘A ∩∘ B. f a)" by auto


subsubsection‹Right restriction›

definition vrrestriction :: "V ⇒ V"
  where "vrrestriction D = 
    VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r})"

abbreviation app_vrrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾r∘› 80)
  where "r ↾r∘ A ≡ vrrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"

lemma app_vrrestriction_def: "r ↾r∘ A = set {⟨a, b⟩ | a b. b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  unfolding vrrestriction_def by simp

lemma vrrestriction_small[simp]: "small {⟨a, b⟩ | a b. b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma vrrestrictionI[intro!]: 
  assumes "⟨r, A⟩ ∈∘ D"
  shows "⟨⟨r, A⟩, r ↾r∘ A⟩ ∈∘ vrrestriction D"
  using assms unfolding vrrestriction_def by (simp add: VLambda_iff2)

lemma vrrestrictionD[dest]: 
  assumes "⟨⟨r, A⟩, s⟩ ∈∘ vrrestriction D" 
  shows "⟨r, A⟩ ∈∘ D" and "s = r ↾r∘ A"
  using assms unfolding vrrestriction_def by auto

lemma vrrestrictionE[elim]: 
  assumes "x ∈∘ vrrestriction D" and "D ⊆∘ R ×∘ X"
  obtains r A where "x = ⟨⟨r, A⟩, r ↾r∘ A⟩" and "r ∈∘ R" and "A ∈∘ X"
  using assms unfolding vrrestriction_def by auto

lemma app_vrrestrictionI[intro!]: 
  assumes "b ∈∘ A" and "⟨a, b⟩ ∈∘ r" 
  shows "⟨a, b⟩ ∈∘ r ↾r∘ A" 
  using assms unfolding vrrestriction_def by simp

lemma app_vrrestrictionD[dest]: 
  assumes "⟨a, b⟩ ∈∘ r ↾r∘ A"  
  shows "b ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vrrestriction_def by auto

lemma app_vrrestrictionE[elim]: 
  assumes "x ∈∘ r ↾r∘ A"
  obtains a b where "x = ⟨a, b⟩" and "b ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vrrestriction_def by auto


text‹Set operations.›

lemma vrrestriction_on_vempty[simp]: "r ↾r∘ 0 = 0" 
  by (auto intro!: vsubset_antisym)

lemma vrrestriction_vempty[simp]: "0 ↾r∘ A = 0" by auto

lemma vrrestriction_vsingleton_in[simp]: 
  assumes "b ∈∘ A"
  shows "set {⟨a, b⟩} ↾r∘ A = set {⟨a, b⟩}" 
  using assms by auto

lemma vrrestriction_vsingleton_nin[simp]: 
  assumes "b ∉∘ A"
  shows "set {⟨a, b⟩} ↾r∘ A = 0" 
  using assms by auto

lemma vrrestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾r∘ A ⊆∘ r ↾r∘ B"
  using assms by auto

lemma vrrestriction_vinsert_nin[simp]:
  assumes "b ∉∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾r∘ A = r ↾r∘ A" 
  using assms by auto

lemma vrrestriction_vinsert_in: 
  assumes "b ∈∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾r∘ A = vinsert ⟨a, b⟩ (r ↾r∘ A)" 
  using assms by auto

lemma vrrestriction_vintersection: "(r ∩∘ s) ↾r∘ A = r ↾r∘ A ∩∘ s ↾r∘ A" by auto

lemma vrrestriction_vunion: "(r ∪∘ s) ↾r∘ A = r ↾r∘ A ∪∘ s ↾r∘ A" by auto

lemma vrrestriction_vdiff: "(r -∘ s) ↾r∘ A = r ↾r∘ A -∘ s ↾r∘ A" by auto


text‹Connections.›

lemma vrrestriction_vid_on[simp]: "(vid_on A) ↾r∘ B = vid_on (A ∩∘ B)" by auto

lemma vrrestriction_vconst_on:
  assumes "c ∈∘ B"
  shows "(vconst_on A c) ↾r∘ B = vconst_on A c"  
  using assms by auto

lemma vrrestriction_vcomp[simp]: "(r ∘∘ s) ↾r∘ A = (r ↾r∘ A) ∘∘ s" by auto


text‹Previous connections.›

lemma vcomp_vid_on_rel[simp]: "vid_on A ∘∘ r = r ↾r∘ A" 
  by (auto intro!: vsubset_antisym)

lemma vcomp_vconst_on_rel: "(vconst_on A c) ∘∘ r = (vconst_on A c) ∘∘ (r ↾r∘ A)"
  by auto

lemma vlrestriction_vconverse: "r¯∘ ↾l∘ A = (r ↾r∘ A)¯∘" by auto

lemma vrrestriction_vconverse: "r¯∘ ↾r∘ A = (r ↾l∘ A)¯∘" by auto


text‹Special properties.›

lemma vrrestriction_vsubset_rel: "r ↾r∘ A ⊆∘ r" by auto

lemma vrrestriction_vsubset_vpairs: "r ↾r∘ A ⊆∘ vpairs r" by auto


subsubsection‹Restriction›

definition vrestriction :: "V ⇒ V"
  where "vrestriction D = 
    VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. a ∈∘ A ∧ b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r})"

abbreviation app_vrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾∘› 80)
  where "r ↾∘ A ≡ vrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"

lemma app_vrestriction_def: 
  "r ↾∘ A = set {⟨a, b⟩ | a b. a ∈∘ A ∧ b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  unfolding vrestriction_def by simp

lemma vrestriction_small[simp]: 
  "small {⟨a, b⟩ | a b. a ∈∘ A ∧ b ∈∘ A ∧ ⟨a, b⟩ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma vrestrictionI[intro!]: 
  assumes "⟨r, A⟩ ∈∘ D"
  shows "⟨⟨r, A⟩, r ↾∘ A⟩ ∈∘ vrestriction D"
  using assms unfolding vrestriction_def by (simp add: VLambda_iff2)

lemma vrestrictionD[dest]: 
  assumes "⟨⟨r, A⟩, s⟩ ∈∘ vrestriction D" 
  shows "⟨r, A⟩ ∈∘ D" and "s = r ↾∘ A"
  using assms unfolding vrestriction_def by auto

lemma vrestrictionE[elim]: 
  assumes "x ∈∘ vrestriction D" and "D ⊆∘ R ×∘ X"
  obtains r A where "x = ⟨⟨r, A⟩, r ↾∘ A⟩" and "r ∈∘ R" and "A ∈∘ X"
  using assms unfolding vrestriction_def by auto

lemma app_vrestrictionI[intro!]: 
  assumes "a ∈∘ A" and "b ∈∘ A" and "⟨a, b⟩ ∈∘ r" 
  shows "⟨a, b⟩ ∈∘ r ↾∘ A" 
  using assms unfolding vrestriction_def by simp

lemma app_vrestrictionD[dest]: 
  assumes "⟨a, b⟩ ∈∘ r ↾∘ A"  
  shows "a ∈∘ A" and "b ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vrestriction_def by auto

lemma app_vrestrictionE[elim]:
  assumes "x ∈∘ r ↾∘ A"
  obtains a b where "x = ⟨a, b⟩" and "a ∈∘ A" and "b ∈∘ A" and "⟨a, b⟩ ∈∘ r"
  using assms unfolding vrestriction_def by clarsimp


text‹Set operations.›

lemma vrestriction_on_vempty[simp]: "r ↾∘ 0 = 0" 
  by (auto intro!: vsubset_antisym)

lemma vrestriction_vempty[simp]: "0 ↾∘ A = 0" by auto

lemma vrestriction_vsingleton_in[simp]: 
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "set {⟨a, b⟩} ↾∘ A = set {⟨a, b⟩}" 
  using assms by auto

lemma vrestriction_vsingleton_nin_left[simp]: 
  assumes "a ∉∘ A"
  shows "set {⟨a, b⟩} ↾∘ A = 0" 
  using assms by auto

lemma vrestriction_vsingleton_nin_right[simp]: 
  assumes "b ∉∘ A"
  shows "set {⟨a, b⟩} ↾∘ A = 0" 
  using assms by auto

lemma vrestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾∘ A ⊆∘ r ↾∘ B"
  using assms by auto

lemma vrestriction_vinsert_nin[simp]: 
  assumes "a ∉∘ A" and "b ∉∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾∘ A = r ↾∘ A" 
  using assms by auto

lemma vrestriction_vinsert_in: 
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "(vinsert ⟨a, b⟩ r) ↾∘ A = vinsert ⟨a, b⟩ (r ↾∘ A)" 
  using assms by auto

lemma vrestriction_vintersection: "(r ∩∘ s) ↾∘ A = r ↾∘ A ∩∘ s ↾∘ A" by auto

lemma vrestriction_vunion: "(r ∪∘ s) ↾∘ A = r ↾∘ A ∪∘ s ↾∘ A" by auto

lemma vrestriction_vdiff: "(r -∘ s) ↾∘ A = r ↾∘ A -∘ s ↾∘ A" by auto


text‹Connections.›

lemma vrestriction_vid_on[simp]: "(vid_on A) ↾∘ B = vid_on (A ∩∘ B)" by auto

lemma vrestriction_vconst_on_ex:
  assumes "c ∈∘ B"
  shows "(vconst_on A c) ↾∘ B = vconst_on (A ∩∘ B) c"  
  using assms by auto

lemma vrestriction_vconst_on_nex:
  assumes "c ∉∘ B"
  shows "(vconst_on A c) ↾∘ B = 0"  
  using assms by auto

lemma vrestriction_vcomp[simp]: "(r ∘∘ s) ↾∘ A = (r ↾r∘ A) ∘∘ (s ↾l∘ A)" by auto

lemma vrestriction_vconverse: "r¯∘ ↾∘ A = (r ↾∘ A)¯∘" by auto


text‹Previous connections.›

lemma vrrestriction_vlrestriction[simp]: "(r ↾r∘ A) ↾l∘ A = r ↾∘ A" by auto

lemma vlrestriction_vrrestriction[simp]: "(r ↾l∘ A) ↾r∘ A = r ↾∘ A" by auto

lemma vrestriction_vlrestriction[simp]: "(r ↾∘ A) ↾l∘ A = r ↾∘ A" by auto

lemma vrestriction_vrrestriction[simp]: "(r ↾∘ A) ↾r∘ A = r ↾∘ A" by auto


text‹Special properties.›

lemma vrestriction_vsubset_vpairs: "r ↾∘ A ⊆∘ vpairs r" by auto

lemma vrestriction_vsubset_vtimes: "r ↾∘ A ⊆∘ A ×∘ A" by auto

lemma vrestriction_vsubset_rel: "r ↾∘ A ⊆∘ r" by auto



subsection‹Properties›


subsubsection‹Domain›

definition vdomain :: "V ⇒ V"
  where "vdomain D = (λr∈∘D. set {a. ∃b. ⟨a, b⟩ ∈∘ r})"

abbreviation app_vdomain :: "V ⇒ V" (‹𝒟∘›)
  where "𝒟∘ r ≡ vdomain (set {r}) ⦇r⦈"

lemma app_vdomain_def: "𝒟∘ r = set {a. ∃b. ⟨a, b⟩ ∈∘ r}"
  unfolding vdomain_def by simp

lemma vdomain_small[simp]: "small {a. ∃b. ⟨a, b⟩ ∈∘ r}"
proof-
  have ss: "{a. ∃b. ⟨a, b⟩ ∈∘ r} ⊆ vfst ` elts r" using image_iff by fastforce
  have small: "small (vfst ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma vdomainI[intro!]: 
  assumes "r ∈∘ A"
  shows "⟨r, 𝒟∘ r⟩ ∈∘ vdomain A"
  using assms unfolding vdomain_def by auto

lemma vdomainD[dest]: 
  assumes "⟨r, s⟩ ∈∘ vdomain A"
  shows "r ∈∘ A" and "s = 𝒟∘ r"
  using assms unfolding vdomain_def by auto

lemma vdomainE[elim]: 
  assumes "x ∈∘ vdomain A" 
  obtains r where "x = ⟨r, 𝒟∘ r⟩" and "r ∈∘ A"
  using assms unfolding vdomain_def by auto

lemma app_vdomainI[intro]:
  assumes "⟨a, b⟩ ∈∘ r"
  shows "a ∈∘ 𝒟∘ r"
  using assms unfolding vdomain_def by auto

lemma app_vdomainD[dest]: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "∃b. ⟨a, b⟩ ∈∘ r" 
  using assms unfolding vdomain_def by auto

lemma app_vdomainE[elim]:
  assumes "a ∈∘ 𝒟∘ r"
  obtains b where "⟨a, b⟩ ∈∘ r"
  using assms unfolding vdomain_def by clarsimp

lemma vdomain_iff: "a ∈∘ 𝒟∘ r ⟷ (∃y. ⟨a, y⟩ ∈∘ r)" by auto


text‹Set operations.›

lemma vdomain_vempty[simp]: "𝒟∘ 0 = 0" by (auto intro!: vsubset_antisym)

lemma vdomain_vsingleton[simp]: "𝒟∘ (set {⟨a, b⟩}) = set {a}" by auto

lemma vdomain_vdoubleton[simp]: "𝒟∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {a, c}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vdomain_mono:
  assumes "r ⊆∘ s"
  shows "𝒟∘ r ⊆∘ 𝒟∘ s"
  using assms by blast

lemma vdomain_vinsert[simp]: "𝒟∘ (vinsert ⟨a, b⟩ r) = vinsert a (𝒟∘ r)" 
  by (auto intro!: vsubset_antisym)

lemma vdomain_vunion: "𝒟∘ (A ∪∘ B) = 𝒟∘ A ∪∘ 𝒟∘ B" 
  by (auto intro!: vsubset_antisym)

lemma vdomain_vintersection_vsubset: "𝒟∘ (A ∩∘ B) ⊆∘ 𝒟∘ A ∩∘ 𝒟∘ B" by auto

lemma vdomain_vdiff_vsubset: "𝒟∘ A -∘ 𝒟∘ B ⊆∘ 𝒟∘ (A -∘ B)" by auto


text‹Connections.›

lemma vdomain_vid_on[simp]: "𝒟∘ (vid_on A) = A" 
  by (auto intro!: vsubset_antisym)

lemma vdomain_vconst_on[simp]: "𝒟∘ (vconst_on A c) = A" 
  by (auto intro!: vsubset_antisym)

lemma vdomain_VLambda[simp]: "𝒟∘ (λa∈∘A. f a) = A" 
  by (auto intro!: vsubset_antisym)

lemma vdomain_vlrestriction: "𝒟∘ (r ↾l∘ A) = 𝒟∘ r ∩∘ A" by auto


text‹Special properties.›

lemma vdomain_vsubset_vtimes:
  assumes "vpairs r ⊆∘ x ×∘ y"
  shows "𝒟∘ r ⊆∘ x"
  using assms by auto


subsubsection‹Range›

definition vrange :: "V ⇒ V"
  where "vrange D = (λr∈∘D. set {b. ∃a. ⟨a, b⟩ ∈∘ r})"

abbreviation app_vrange :: "V ⇒ V" (‹ℛ∘›)
  where "ℛ∘ r ≡ vrange (set {r}) ⦇r⦈"

lemma app_vrange_def: "ℛ∘ r = set {b. ∃a. ⟨a, b⟩ ∈∘ r}"
  unfolding vrange_def by simp

lemma vrange_small[simp]: "small {b. ∃a. ⟨a, b⟩ ∈∘ r}"
proof-
  have ss: "{b. ∃a. ⟨a, b⟩ ∈∘ r} ⊆ vsnd ` elts r" using image_iff by fastforce
  have small: "small (vsnd ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma vrangeI[intro]: 
  assumes "r ∈∘ A"
  shows "⟨r, ℛ∘ r⟩ ∈∘ vrange A"
  using assms unfolding vrange_def by auto

lemma vrangeD[dest]: 
  assumes "⟨r, s⟩ ∈∘ vrange A"
  shows "r ∈∘ A" and "s = ℛ∘ r"
  using assms unfolding vrange_def by auto

lemma vrangeE[elim]: 
  assumes "x ∈∘ vrange A" 
  obtains r where "x = ⟨r, ℛ∘ r⟩" and "r ∈∘ A"
  using assms unfolding vrange_def by auto

lemma app_vrangeI[intro]: 
  assumes "⟨a, b⟩ ∈∘ r"
  shows "b ∈∘ ℛ∘ r"
  using assms unfolding vrange_def by auto

lemma app_vrangeD[dest]: 
  assumes "b ∈∘ ℛ∘ r"
  shows "∃a. ⟨a, b⟩ ∈∘ r" 
  using assms unfolding vrange_def by simp

lemma app_vrangeE[elim]:
  assumes "b ∈∘ ℛ∘ r"
  obtains a where "⟨a, b⟩ ∈∘ r"
  using assms unfolding vrange_def by clarsimp

lemma vrange_iff: "b ∈∘ ℛ∘ r ⟷ (∃a. ⟨a, b⟩ ∈∘ r)" by auto


text‹Set operations.›

lemma vrange_vempty[simp]: "ℛ∘ 0 = 0" by (auto intro!: vsubset_antisym)

lemma vrange_vsingleton[simp]: "ℛ∘ (set {⟨a, b⟩}) = set {b}" by auto

lemma vrange_vdoubleton[simp]: "ℛ∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {b, d}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vrange_mono: 
  assumes "r ⊆∘ s"
  shows "ℛ∘ r ⊆∘ ℛ∘ s"
  using assms by force

lemma vrange_vinsert[simp]: "ℛ∘ (vinsert ⟨a, b⟩ r) = vinsert b (ℛ∘ r)" 
  by (auto intro!: vsubset_antisym)

lemma vrange_vunion: "ℛ∘ (r ∪∘ s) = ℛ∘ r ∪∘ ℛ∘ s" 
  by (auto intro!: vsubset_antisym)

lemma vrange_vintersection_vsubset: "ℛ∘ (r ∩∘ s) ⊆∘ ℛ∘ r ∩∘ ℛ∘ s" by auto

lemma vrange_vdiff_vsubset: "ℛ∘ r -∘ ℛ∘ s ⊆∘ ℛ∘ (r -∘ s)" by auto


text‹Connections.›

lemma vrange_vid_on[simp]: "ℛ∘ (vid_on A) = A" by (auto intro!: vsubset_antisym)

lemma vrange_vconst_on_vempty[simp]: "ℛ∘ (vconst_on 0 c) = 0" by auto

lemma vrange_vconst_on_ne[simp]: 
  assumes "A ≠ 0"
  shows "ℛ∘ (vconst_on A c) = set {c}"
  using assms by (auto intro!: vsubset_antisym)

lemma vrange_VLambda: "ℛ∘ (λa∈∘A. f a) = set (f ` elts A)"
  by (intro vsubset_antisym vsubsetI) auto

lemma vrange_vrrestriction: "ℛ∘ (r ↾r∘ A) = ℛ∘ r ∩∘ A" by auto


text‹Previous connections›

lemma vdomain_vconverse[simp]: "𝒟∘ (r¯∘) = ℛ∘ r" 
  by (auto intro!: vsubset_antisym)

lemma vrange_vconverse[simp]: "ℛ∘ (r¯∘) = 𝒟∘ r" 
  by (auto intro!: vsubset_antisym)


text‹Special properties.›

lemma vrange_iff_vdomain: "b ∈∘ ℛ∘ r ⟷ (∃a∈∘𝒟∘ r. ⟨a, b⟩ ∈∘ r)" by auto

lemma vrange_vsubset_vtimes:
  assumes "vpairs r ⊆∘ x ×∘ y"
  shows "ℛ∘ r ⊆∘ y"
  using assms by auto

lemma vrange_VLambda_vsubset:
  assumes "⋀x. x ∈∘ A ⟹ f x ∈∘ B"
  shows "ℛ∘ (VLambda A f) ⊆∘ B"
  using assms by auto

lemma vpairs_vsubset_vdomain_vrange[simp]: "vpairs r ⊆∘ 𝒟∘ r ×∘ ℛ∘ r" 
  by (rule vsubsetI) auto

lemma vrange_vsubset:
  assumes "⋀x y. ⟨x, y⟩ ∈∘ r ⟹ y ∈∘ A"
  shows "ℛ∘ r ⊆∘ A"
  using assms by auto


subsubsection‹Field›

definition vfield :: "V ⇒ V"
  where "vfield D = (λr∈∘D. 𝒟∘ r ∪∘ ℛ∘ r)"

abbreviation app_vfield :: "V ⇒ V" (‹ℱ∘›)
  where "ℱ∘ r ≡ vfield (set {r}) ⦇r⦈"

lemma app_vfield_def: "ℱ∘ r = 𝒟∘ r ∪∘ ℛ∘ r" unfolding vfield_def by simp


text‹Rules.›

lemma vfieldI[intro!]: 
  assumes "r ∈∘ A"
  shows "⟨r, ℱ∘ r⟩ ∈∘ vfield A"
  using assms unfolding vfield_def by auto

lemma vfieldD[dest]: 
  assumes "⟨r, s⟩ ∈∘ vfield A"
  shows "r ∈∘ A" and "s = ℱ∘ r"
  using assms unfolding vfield_def by auto

lemma vfieldE[elim]: 
  assumes "x ∈∘ vfield A" 
  obtains r where "x = ⟨r, ℱ∘ r⟩" and "r ∈∘ A"
  using assms unfolding vfield_def by auto

lemma app_vfieldI1[intro]: 
  assumes "a ∈∘ 𝒟∘ r ∪∘ ℛ∘ r"
  shows "a ∈∘ ℱ∘ r"
  using assms unfolding vfield_def by simp

lemma app_vfieldI2[intro]: 
  assumes "⟨a, b⟩ ∈∘ r"
  shows "a ∈∘ ℱ∘ r"
  using assms by auto

lemma app_vfieldI3[intro]: 
  assumes "⟨a, b⟩ ∈∘ r"
  shows "b ∈∘ ℱ∘ r"
  using assms by auto

lemma app_vfieldD[dest]: 
  assumes "a ∈∘ ℱ∘ r"
  shows "a ∈∘ 𝒟∘ r ∪∘ ℛ∘ r"
  using assms unfolding vfield_def by simp

lemma app_vfieldE[elim]:  
  assumes "a ∈∘ ℱ∘ r" and "a ∈∘ 𝒟∘ r ∪∘ ℛ∘ r ⟹ P"
  shows P
  using assms by auto

lemma app_vfield_vpairE[elim]:
  assumes "a ∈∘ ℱ∘ r"
  obtains b where "⟨a, b⟩ ∈∘ r ∨ ⟨b, a⟩ ∈∘ r "
  using assms unfolding app_vfield_def by blast

lemma vfield_iff: "a ∈∘ ℱ∘ r ⟷ (∃b. ⟨a, b⟩ ∈∘ r ∨ ⟨b, a⟩ ∈∘ r)" by auto


text‹Set operations.›

lemma vfield_vempty[simp]: "ℱ∘ 0 = 0" by (auto intro!: vsubset_antisym)

lemma vfield_vsingleton[simp]: "ℱ∘ (set {⟨a, b⟩}) = set {a, b}" 
  by (simp add: app_vfield_def vinsert_set_insert_eq)

lemma vfield_vdoubleton[simp]: "ℱ∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {a, b, c, d}" 
  by (auto simp: vinsert_set_insert_eq)

lemma vfield_mono:
  assumes "r ⊆∘ s"
  shows "ℱ∘ r ⊆∘ ℱ∘ s"
  using assms by fastforce

lemma vfield_vinsert[simp]: "ℱ∘ (vinsert ⟨a, b⟩ r) = set {a, b} ∪∘ ℱ∘ r"
  by (auto intro!: vsubset_antisym)

lemma vfield_vunion[simp]: "ℱ∘ (r ∪∘ s) = ℱ∘ r ∪∘ ℱ∘ s" 
  by (auto intro!: vsubset_antisym)


text‹Connections.›

lemma vid_on_vfield[simp]: "ℱ∘ (vid_on A) = A" by (auto intro!: vsubset_antisym)

lemma vconst_on_vfield_ne[intro, simp]:
  assumes "A ≠ 0"
  shows "ℱ∘ (vconst_on A c) = vinsert c A" 
  using assms by (auto intro!: vsubset_antisym)

lemma vconst_on_vfield_vempty[simp]: "ℱ∘ (vconst_on 0 c) = 0" by auto

lemma vfield_vconverse[simp]: "ℱ∘ (r¯∘) = ℱ∘ r" 
  by (auto intro!: vsubset_antisym)


subsubsection‹Image›

definition vimage :: "V ⇒ V"
  where "vimage D = VLambda D (λ⟨r, A⟩. ℛ∘ (r ↾l∘ A))"

abbreviation app_vimage :: "V ⇒ V ⇒ V" (infixr ‹`∘› 90)
  where "r `∘ A ≡ vimage (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"

lemma app_vimage_def: "r `∘ A = ℛ∘ (r ↾l∘ A)" unfolding vimage_def by simp

lemma vimage_small[simp]: "small {b. ∃a∈∘A. ⟨a, b⟩ ∈∘ r}"
proof-
  have ss: "{b. ∃a∈∘A. ⟨a, b⟩ ∈∘ r} ⊆ vsnd ` elts r"
    using image_iff by fastforce
  have small: "small (vsnd ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed

lemma app_vimage_set_def: "r `∘ A = set {b. ∃a∈∘A. ⟨a, b⟩ ∈∘ r}"
  unfolding vimage_def vrange_def by auto


text‹Rules.›

lemma vimageI[intro!]: 
  assumes "⟨r, A⟩ ∈∘ D"
  shows "⟨⟨r, A⟩, r `∘ A⟩ ∈∘ vimage D"
  using assms unfolding vimage_def by (simp add: VLambda_iff2)

lemma vimageD[dest]: 
  assumes "⟨⟨r, A⟩, s⟩ ∈∘ vimage D" 
  shows "⟨r, A⟩ ∈∘ D" and "s = r `∘ A"
  using assms unfolding vimage_def by auto

lemma vimageE[elim]: 
  assumes "x ∈∘ vimage (R ×∘ X)"
  obtains r A where "x = ⟨⟨r, A⟩, r `∘ A⟩" and "r ∈∘ R" and "A ∈∘ X"
  using assms unfolding vimage_def by auto

lemma app_vimageI1:
  assumes "x ∈∘ ℛ∘ (r ↾l∘ A)"
  shows "x ∈∘ r `∘ A" 
  using assms unfolding vimage_def by simp

lemma app_vimageI2[intro]:
  assumes "⟨a, b⟩ ∈∘ r" and "a ∈∘ A" 
  shows "b ∈∘ r `∘ A"
  using assms app_vimageI1 by auto

lemma app_vimageD[dest]: 
  assumes "x ∈∘ r `∘ A"
  shows "x ∈∘ ℛ∘ (r ↾l∘ A)"
  using assms unfolding vimage_def by simp

lemma app_vimageE[elim]:
  assumes "b ∈∘ r `∘ A"
  obtains a where "⟨a, b⟩ ∈∘ r" and "a ∈∘ A"
  using assms unfolding vimage_def by auto

lemma app_vimage_iff: "b ∈∘ r `∘ A ⟷ (∃a∈∘A. ⟨a, b⟩ ∈∘ r)" by auto


text‹Set operations.›

lemma vimage_vempty[simp]: "0 `∘ A = 0" by (auto intro!: vsubset_antisym)

lemma vimage_of_vempty[simp]: "r `∘ 0 = 0" by (auto intro!: vsubset_antisym)

lemma vimage_vsingleton: "r `∘ set {a} = set {b. ⟨a, b⟩ ∈∘ r}"
proof-
  have "{b. ⟨a, b⟩ ∈∘ r} ⊆ {b. ∃a. ⟨a, b⟩ ∈∘ r}" by auto
  then have [simp]: "small {b. ⟨a, b⟩ ∈∘ r}" 
    by (rule smaller_than_small[OF vrange_small[of r]])
  show ?thesis using app_vimage_set_def by auto
qed

lemma vimage_vsingleton_in[intro, simp]: 
  assumes "a ∈∘ A"
  shows "set {⟨a, b⟩} `∘ A = set {b}" 
  using assms by auto

lemma vimage_vsingleton_nin[intro, simp]: 
  assumes "a ∉∘ A"
  shows "set {⟨a, b⟩} `∘ A = 0" 
  using assms by auto

lemma vimage_vsingleton_vinsert[simp]: "set {⟨a, b⟩} `∘ vinsert a A = set {b}" 
  by auto

lemma vimage_mono: 
  assumes "r' ⊆∘ r" and "A' ⊆∘ A"
  shows "(r' `∘ A') ⊆∘ (r `∘ A)" 
  using assms by fastforce

lemma vimage_vinsert: "r `∘ (vinsert a A) = r `∘ set {a} ∪∘ r `∘ A" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vunion_left: "(r ∪∘ s) `∘ A = r `∘ A ∪∘ s `∘ A" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vunion_right: "r `∘ (A ∪∘ B) = r `∘ A ∪∘ r `∘ B" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vintersection: "r `∘ (A ∩∘ B) ⊆∘ r `∘ A ∩∘ r `∘ B" by auto

lemma vimage_vdiff: "r `∘ A -∘ r `∘ B ⊆∘ r `∘ (A -∘ B)" by auto


text‹Previous set operations.›

lemma VPow_vinsert:
  "VPow (vinsert a A) = VPow A ∪∘ ((λx∈∘VPow A. vinsert a x) `∘ VPow A)"
proof(intro vsubset_antisym vsubsetI)
  fix x assume "x ∈∘ VPow (vinsert a A)"
  then have "x ⊆∘ vinsert a A" by simp
  then consider "x ⊆∘ A" | "a ∈∘ x" by auto
  then show "x ∈∘ VPow A ∪∘ (λx∈∘VPow A. vinsert a x) `∘ VPow A"
  proof cases
    case 1 then show ?thesis by simp
  next
    case 2
    define x' where "x' = x -∘ set {a}"
    with 2 have "x = vinsert a x'" and "a ∉∘ x'" by auto
    with ‹x ⊆∘ vinsert a A› show ?thesis
      unfolding vimage_def
      by (fastforce simp: vsubset_vinsert vlrestriction_VLambda)
  qed
qed (elim vunionE, auto)


text‹Special properties.›

lemma vimage_vsingleton_iff[iff]: "b ∈∘ r `∘ set {a} ⟷ ⟨a, b⟩ ∈∘ r" by auto

lemma vimage_is_vempty[iff]: "r `∘ A = 0 ⟷ vdisjnt (𝒟∘ r) A" by fastforce

lemma vcomp_vimage_vtimes_right: 
  assumes "r `∘ Y = Z"
  shows "r ∘∘ (X ×∘ Y) = X ×∘ Z"
proof(intro vsubset_antisym vsubsetI)
  fix x assume x: "x ∈∘ r ∘∘ (X ×∘ Y)"
  then obtain a c where x_def: "x = ⟨a, c⟩" and "a ∈∘ X" and "c ∈∘ ℛ∘ r" by auto
  with x obtain b where "⟨a, b⟩ ∈∘ X ×∘ Y" and "⟨b, c⟩ ∈∘ r" by clarsimp
  then show "x ∈∘ X ×∘ Z" unfolding x_def using assms by auto
next
  fix x assume "x ∈∘ X ×∘ Z"
  then obtain a c where x_def: "x = ⟨a, c⟩" and "a ∈∘ X" and "c ∈∘ Z" by auto
  then show "x ∈∘ r ∘∘ X ×∘ Y"
    using assms unfolding x_def by (meson VSigmaI app_vimageE vcompI)
qed


text‹Connections.›

lemma vid_on_vimage[simp]: "vid_on A `∘ B = A ∩∘ B" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vconst_on_ne[simp]: 
  assumes "B ∩∘ A ≠ 0"
  shows "vconst_on A c `∘ B = set {c}" 
  using assms by auto

lemma vimage_vconst_on_vempty[simp]: 
  assumes "vdisjnt A B"
  shows "vconst_on A c `∘ B = 0" 
  using assms by auto

lemma vimage_vconst_on_vsubset_vconst: "vconst_on A c `∘ B ⊆∘ set {c}" by auto

lemma vimage_VLambda_vrange: "(λa∈∘A. f a) `∘ B = ℛ∘ (λa∈∘A ∩∘ B. f a)"
  unfolding vimage_def by (simp add: vlrestriction_VLambda)

lemma vimage_VLambda_vrange_rep: "(λa∈∘A. f a) `∘ A = ℛ∘ (λa∈∘A. f a)"
  by (simp add: vimage_VLambda_vrange)

lemma vcomp_vimage: "(r ∘∘ s) `∘ A = r `∘ (s `∘ A)" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vlrestriction[simp]: "(r ↾l∘ A) `∘ B = r `∘ (A ∩∘ B)" 
  by (auto intro!: vsubset_antisym)

lemma vimage_vrrestriction[simp]: "(r ↾r∘ A) `∘ B = A ∩∘ r `∘ B" by auto

lemma vimage_vrestriction[simp]: "(r ↾∘ A) `∘ B = A ∩∘ (r `∘ (A ∩∘ B))" by auto

lemma vimage_vdomain: "r `∘ 𝒟∘ r = ℛ∘ r" by (auto intro!: vsubset_antisym)

lemma vimage_eq_imp_vcomp: 
  assumes "r `∘ A = s `∘ B"
  shows "(t ∘∘ r) `∘ A = (t ∘∘ s) `∘ B"
  using assms by (metis vcomp_vimage)


text‹Previous connections.›

lemma vcomp_rel_vconst: "r ∘∘ (vconst_on A c) = A ×∘ (r `∘ set {c})" 
  by auto

lemma vcomp_VLambda:
  "(λb∈∘((λa∈∘A. g a) `∘ A). f b) ∘∘ (λa∈∘A. g a) = (λa∈∘A. (f ∘ g) a)" 
  using VLambda_iff1 by (auto intro!: vsubset_antisym)+


text‹Further special properties.›

lemma vimage_vsubset: 
  assumes "r ⊆∘ A ×∘ B"
  shows "r `∘ C ⊆∘ B" 
  using assms by auto

lemma vimage_vdomain_vsubset: "r `∘ A ⊆∘ r `∘ 𝒟∘ r" by auto

lemma vdomain_vsubset_VUnion2: "𝒟∘ r ⊆∘ ⋃∘(⋃∘r)"
proof(intro vsubsetI)
  fix x assume "x ∈∘ 𝒟∘ r"
  then obtain y where "⟨x, y⟩ ∈∘ r" by auto
  then have "set {set {x}, set {x, y}} ∈∘ r" unfolding vpair_def by auto
  with insert_commute have xy_Ur: "set {x, y} ∈∘ ⋃∘r" 
    unfolding VUnion_iff by auto
  define Ur where "Ur = ⋃∘r"
  from xy_Ur show "x ∈∘ ⋃∘(⋃∘r)"
    unfolding Ur_def[symmetric] by (auto dest: VUnionI)
qed

lemma vrange_vsubset_VUnion2: "ℛ∘ r ⊆∘ ⋃∘(⋃∘r)"
proof(intro vsubsetI)
  fix y assume "y ∈∘ ℛ∘ r"
  then obtain x where "⟨x, y⟩ ∈∘ r" by auto
  then have "set {set {x}, set {x, y}} ∈∘ r" unfolding vpair_def by auto
  with insert_commute have xy_Ur: "set {x, y} ∈∘ ⋃∘r" 
    unfolding VUnion_iff by auto
  define Ur where "Ur = ⋃∘r"
  from xy_Ur show "y ∈∘ ⋃∘(⋃∘r)"
    unfolding Ur_def[symmetric] by (auto dest: VUnionI)
qed

lemma vfield_vsubset_VUnion2: "ℱ∘ r ⊆∘ ⋃∘(⋃∘r)"
  using vdomain_vsubset_VUnion2 vrange_vsubset_VUnion2 
  by (auto simp: app_vfield_def)


subsubsection‹Inverse image›

definition invimage :: "V ⇒ V"
  where "invimage D = VLambda D (λ⟨r, A⟩. r¯∘ `∘ A)"

abbreviation app_invimage :: "V ⇒ V ⇒ V" (infixr ‹-`∘› 90)
  where "r -`∘ A ≡ invimage (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"

lemma app_invimage_def: "r -`∘ A = r¯∘ `∘ A" unfolding invimage_def by simp

lemma invimage_small[simp]: "small {a. ∃b∈∘A. ⟨a, b⟩ ∈∘ r}"
proof-
  have ss: "{a. ∃b∈∘A. ⟨a, b⟩ ∈∘ r} ⊆ vfst ` elts r" 
    using image_iff by fastforce
  have small: "small (vfst ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma invimageI[intro!]: 
  assumes "⟨r, A⟩ ∈∘ D"
  shows "⟨⟨r, A⟩, r -`∘ A⟩ ∈∘ invimage D"
  using assms unfolding invimage_def by (simp add: VLambda_iff2)

lemma invimageD[dest]: 
  assumes "⟨⟨r, A⟩, s⟩ ∈∘ invimage D" 
  shows "⟨r, A⟩ ∈∘ D" and "s = r -`∘ A"
  using assms unfolding invimage_def by auto

lemma invimageE[elim]: 
  assumes "x ∈∘ invimage D" and "D ⊆∘ R ×∘ X"
  obtains r A where "x = ⟨⟨r, A⟩, r -`∘ A⟩" and "r ∈∘ R" and "A ∈∘ X"
  using assms unfolding invimage_def by auto

lemma app_invimageI[intro]:
  assumes "⟨a, b⟩ ∈∘ r" and "b ∈∘ A" 
  shows "a ∈∘ r -`∘ A"
  using assms invimage_def by auto

lemma app_invimageD[dest]: 
  assumes "a ∈∘ r -`∘ A"
  shows "a ∈∘ 𝒟∘ (r ↾r∘ A)"
  using assms using invimage_def by auto

lemma app_invimageE[elim]:
  assumes "a ∈∘ r -`∘ A"
  obtains b where "⟨a, b⟩ ∈∘ r" and "b ∈∘ A"
  using assms unfolding invimage_def by auto

lemma app_invimageI1: 
  assumes "a ∈∘ 𝒟∘ (r ↾r∘ A)"
  shows "a ∈∘ r -`∘ A" 
  using assms unfolding vimage_def 
  by (simp add: invimage_def app_vimageI1 vlrestriction_vconverse)

lemma app_invimageD1: 
  assumes "a ∈∘ r -`∘ A"
  shows "a ∈∘ 𝒟∘ (r ↾r∘ A)"
  using assms by fastforce
                                       
lemma app_invimageE1:
  assumes "a ∈∘ r -`∘ A " and "a ∈∘ 𝒟∘ (r ↾r∘ A) ⟹ P"
  shows P
  using assms unfolding invimage_def by auto

lemma app_invimageI2: 
  assumes "a ∈∘ r¯∘ `∘ A"
  shows "a ∈∘ r -`∘ A" 
  using assms unfolding invimage_def by simp

lemma app_invimageD2:
  assumes "a ∈∘ r -`∘ A"
  shows "a ∈∘ r¯∘ `∘ A"
  using assms unfolding invimage_def by simp

lemma app_invimageE2:
  assumes "a ∈∘ r -`∘ A" and "a ∈∘ r¯∘ `∘ A ⟹ P"
  shows P
  unfolding vimage_def by (simp add: assms app_invimageD2)

lemma invimage_iff: "a ∈∘ r -`∘ A ⟷ (∃b∈∘A. ⟨a, b⟩ ∈∘ r)" by auto

lemma invimage_iff1: "a ∈∘ r -`∘ A ⟷ a ∈∘ 𝒟∘ (r ↾r∘ A)" by auto

lemma invimage_iff2: "a ∈∘ r -`∘ A ⟷ a ∈∘ r¯∘ `∘ A" by auto


text‹Set operations.›

lemma invimage_vempty[simp]: "0 -`∘ A = 0" by (auto intro!: vsubset_antisym)

lemma invimage_of_vempty[simp]: "r -`∘ 0 = 0" by (auto intro!: vsubset_antisym)

lemma invimage_vsingleton_in[intro, simp]: 
  assumes "b ∈∘ A"
  shows "set {⟨a, b⟩} -`∘ A = set {a}" 
  using assms by auto

lemma invimage_vsingleton_nin[intro, simp]: 
  assumes "b ∉∘ A"
  shows "set {⟨a, b⟩} -`∘ A = 0" 
  using assms by auto

lemma invimage_vsingleton_vinsert[intro, simp]: 
  "set {⟨a, b⟩} -`∘ vinsert b A = set {a}" 
  by auto

lemma invimage_mono: 
  assumes "r' ⊆∘ r" and "A' ⊆∘ A"
  shows "(r' -`∘ A') ⊆∘ (r -`∘ A)" 
  using assms by fastforce

lemma invimage_vinsert: "r -`∘ (vinsert a A) = r -`∘ set {a} ∪∘ r -`∘ A" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vunion_left: "(r ∪∘ s) -`∘ A = r -`∘ A ∪∘ s -`∘ A" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vunion_right: "r -`∘ (A ∪∘ B) = r -`∘ A ∪∘ r -`∘ B" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vintersection: "r -`∘ (A ∩∘ B) ⊆∘ r -`∘ A ∩∘ r -`∘ B" by auto

lemma invimage_vdiff: "r -`∘ A -∘ r -`∘ B ⊆∘ r -`∘ (A -∘ B)" by auto


text‹Special properties.›

lemma invimage_set_def: "r -`∘ A = set {a. ∃b∈∘A. ⟨a, b⟩ ∈∘ r}" by fastforce

lemma invimage_eq_vdomain_vrestriction: "r -`∘ A = 𝒟∘ (r ↾r∘ A)" by fastforce

lemma invimage_vrange[simp]: "r -`∘ ℛ∘ r = 𝒟∘ r"
  unfolding invimage_def by (auto intro!: vsubset_antisym)

lemma invimage_vrange_vsubset[simp]: 
  assumes "ℛ∘ r ⊆∘ B"
  shows "r -`∘ B = 𝒟∘ r"
  using assms unfolding app_invimage_def by (blast intro!: vsubset_antisym)


text‹Connections.›

lemma invimage_vid_on[simp]: "vid_on A -`∘ B = A ∩∘ B" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vconst_on_vsubset_vdomain[simp]: "vconst_on A c -`∘ B ⊆∘ A" 
  unfolding invimage_def by auto

lemma invimage_vconst_on_ne[simp]: 
  assumes "c ∈∘ B"
  shows "vconst_on A c -`∘ B = A" 
  by (simp add: assms invimage_eq_vdomain_vrestriction vrrestriction_vconst_on)

lemma invimage_vconst_on_vempty[simp]: 
  assumes "c ∉∘ B"
  shows "vconst_on A c -`∘ B = 0" 
  using assms by auto

lemma invimage_vcomp: "(r ∘∘ s) -`∘ x = s -`∘ (r -`∘ x) "
  by (simp add: invimage_def vconverse_vcomp vcomp_vimage)

lemma invimage_vconverse[simp]: "r¯∘ -`∘ A = r `∘ A" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vlrestriction[simp]: "(r ↾l∘ A) -`∘ B = A ∩∘ r -`∘ B" by auto

lemma invimage_vrrestriction[simp]: "(r ↾r∘ A) -`∘ B = (r -`∘ (A ∩∘ B))" 
  by (auto intro!: vsubset_antisym)

lemma invimage_vrestriction[simp]: "(r ↾∘ A) -`∘ B = A ∩∘ (r -`∘ (A ∩∘ B))" 
  by blast


text‹Previous connections.›

lemma vcomp_vconst_on_rel_vtimes: "vconst_on A c ∘∘ r = (r -`∘ A) ×∘ set {c}"
proof(intro vsubset_antisym vsubsetI)
  fix x assume "x ∈∘ r -`∘ A ×∘ set {c}" 
  then obtain a where x_def: "x = ⟨a, c⟩" and "a ∈∘ r -`∘ A" by auto
  then obtain b where ab: "⟨a, b⟩ ∈∘ r" and "b ∈∘ A" using invimage_iff by auto
  with ‹b ∈∘ A› show "x ∈∘ vconst_on A c ∘∘ r" unfolding x_def by auto
qed auto

lemma vdomain_vcomp[simp]: "𝒟∘ (r ∘∘ s) = s -`∘ 𝒟∘ r" by blast

lemma vrange_vcomp[simp]: "ℛ∘ (r ∘∘ s) = r `∘ ℛ∘ s" by blast

lemma vdomain_vcomp_vsubset:
  assumes "ℛ∘ s ⊆∘ 𝒟∘ r"
  shows "𝒟∘ (r ∘∘ s) = 𝒟∘ s"
  using assms by simp



subsection‹Classification of relations›


subsubsection‹Binary relation›

locale vbrelation = 
  fixes r :: V
  assumes vbrelation: "vpairs r = r"


text‹Rules.›

lemma vpairs_eqI[intro!]:
  assumes "⋀x. x ∈∘ r ⟹ ∃a b. x = ⟨a, b⟩"
  shows "vpairs r = r"
  using assms by auto

lemma vpairs_eqD[dest]: 
  assumes "vpairs r = r"
  shows "⋀x. x ∈∘ r ⟹ ∃a b. x = ⟨a, b⟩"
  using assms by auto

lemma vpairs_eqE[elim!]: 
  assumes "vpairs r = r" and "(⋀x. x ∈∘ r ⟹ ∃a b. x = ⟨a, b⟩) ⟹ P"
  shows P
  using assms by auto

lemmas vbrelationI[intro!] = vbrelation.intro 
lemmas vbrelationD[dest!] = vbrelation.vbrelation

lemma vbrelationE[elim!]: 
  assumes "vbrelation r" and "(vpairs r = r) ⟹ P"
  shows P
  using assms unfolding vbrelation_def by auto

lemma vbrelationE1[elim]:
  assumes "vbrelation r" and "x ∈∘ r" 
  obtains a b where "x = ⟨a, b⟩"
  using assms by auto

lemma vbrelationD1[dest]:
  assumes "vbrelation r" and "x ∈∘ r" 
  shows "∃a b. x = ⟨a, b⟩"
  using assms by auto

lemma (in vbrelation) vbrelation_vinE:
  assumes "x ∈∘ r" 
  obtains a b where "x = ⟨a, b⟩" and "a ∈∘ 𝒟∘ r" and "b ∈∘ ℛ∘ r"
  using assms vbrelation_axioms by blast


text‹Set operations.›

lemma vbrelation_vsubset:
  assumes "vbrelation s" and "r ⊆∘ s" 
  shows "vbrelation r"
  using assms by auto

lemma vbrelation_vinsert[simp]: "vbrelation (vinsert ⟨a, b⟩ r) ⟷ vbrelation r"  
  by auto

lemma (in vbrelation) vbrelation_vinsertI[intro, simp]: 
  "vbrelation (vinsert ⟨a, b⟩ r)"
  using vbrelation_axioms by auto

lemma vbrelation_vinsertD[dest]:
  assumes "vbrelation (vinsert ⟨a, b⟩ r)"
  shows "vbrelation r"
  using assms by auto

lemma vbrelation_vunion: "vbrelation (r ∪∘ s) ⟷ vbrelation r ∧ vbrelation s"
  by auto

lemma vbrelation_vunionI: 
  assumes "vbrelation r" and "vbrelation s"
  shows "vbrelation (r ∪∘ s)"
  using assms by auto

lemma vbrelation_vunionD[dest]: 
  assumes "vbrelation (r ∪∘ s)"
  shows "vbrelation r" and "vbrelation s"
  using assms by auto

lemma (in vbrelation) vbrelation_vintersectionI: "vbrelation (r ∩∘ s)"
  using vbrelation_axioms by auto

lemma (in vbrelation) vbrelation_vdiffI: "vbrelation (r -∘ s)"
  using vbrelation_axioms by auto


text‹Connections.›

lemma vbrelation_vempty: "vbrelation 0" by auto

lemma vbrelation_vsingleton: "vbrelation (set {⟨a, b⟩})" by auto

lemma vbrelation_vdoubleton: "vbrelation (set {⟨a, b⟩, ⟨c, d⟩})" by auto

lemma vbrelation_vid_on[simp]: "vbrelation (vid_on A)" by auto

lemma vbrelation_vconst_on[simp]: "vbrelation (vconst_on A c)" by auto

lemma vbrelation_VLambda[simp]: "vbrelation (VLambda A f)"
  unfolding VLambda_def by (intro vbrelationI) auto
  
global_interpretation rel_VLambda: vbrelation ‹VLambda U f› 
  by (rule vbrelation_VLambda)

lemma vbrelation_vcomp: 
  assumes "vbrelation r" and "vbrelation s"
  shows "vbrelation (r ∘∘ s)" 
  using assms by auto

lemma (in vbrelation) vbrelation_vconverse: "vbrelation (r¯∘)"
  using vbrelation_axioms by clarsimp

lemma vbrelation_vlrestriction[intro, simp]: "vbrelation (r ↾l∘ A)" by auto

lemma vbrelation_vrrestriction[intro, simp]: "vbrelation (r ↾r∘ A)" by auto

lemma vbrelation_vrestriction[intro, simp]: "vbrelation (r ↾∘ A)" by auto


text‹Previous connections.›

lemma (in vbrelation) vconverse_vconverse[simp]: "(r¯∘)¯∘ = r"
  using vbrelation_axioms by auto

lemma vconverse_mono[simp]: 
  assumes "vbrelation r" and "vbrelation s"
  shows "r¯∘ ⊆∘ s¯∘ ⟷ r ⊆∘ s"
  using assms by (force intro: vconverse_vunion)+

lemma vconverse_inject[simp]: 
  assumes "vbrelation r" and "vbrelation s"
  shows "r¯∘ = s¯∘ ⟷ r = s"
  using assms by fast

lemma (in vbrelation) vconverse_vsubset_swap_2: 
  assumes "r¯∘ ⊆∘ s"
  shows "r ⊆∘ s¯∘" 
  using assms vbrelation_axioms by auto

lemma (in vbrelation) vlrestriction_vdomain[simp]: "r ↾l∘ 𝒟∘ r = r"
  using vbrelation_axioms by (elim vbrelationE) auto

lemma (in vbrelation) vrrestriction_vrange[simp]: "r ↾r∘ ℛ∘ r = r"
  using vbrelation_axioms by (elim vbrelationE) auto


text‹Special properties.›

lemma brel_vsubset_vtimes:
  "vbrelation r ⟷ r ⊆∘ set (vfst ` elts r) ×∘ set (vsnd ` elts r)"
  by force

lemma vsubset_vtimes_vbrelation: 
  assumes "r ⊆∘ A ×∘ B"
  shows "vbrelation r" 
  using assms by auto

lemma (in vbrelation) vbrelation_vintersection_vdomain:
  assumes "vdisjnt (𝒟∘ r) (𝒟∘ s)"
  shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "⟨a, b⟩ ∈∘ r ∩∘ s"
    by (metis vbrelationE1 vbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed simp

lemma (in vbrelation) vbrelation_vintersection_vrange:
  assumes "vdisjnt (ℛ∘ r) (ℛ∘ s)"
  shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "⟨a, b⟩ ∈∘ r ∩∘ s"
    by (metis vbrelationE1 vbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed simp

lemma (in vbrelation) vbrelation_vintersection_vfield:
  assumes "vdisjnt (vfield r) (vfield s)"
  shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "⟨a, b⟩ ∈∘ r ∩∘ s"
    by (metis vbrelationE1 vbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed auto

lemma (in vbrelation) vdomain_vrange_vtimes: "r ⊆∘ 𝒟∘ r ×∘ ℛ∘ r"
  using vbrelation by auto

lemma (in vbrelation) vbrelation_vsubset_vtimes:
  assumes "𝒟∘ r ⊆∘ A" and "ℛ∘ r ⊆∘ B"
  shows "r ⊆∘ A ×∘ B"
proof(intro vsubsetI)
  fix x assume prems: "x ∈∘ r"
  with vbrelation obtain a b where x_def: "x = ⟨a, b⟩" by auto
  from prems have a: "a ∈∘ 𝒟∘ r" and b: "b ∈∘ ℛ∘ r" unfolding x_def by auto
  with assms have "a ∈∘ A" and "b ∈∘ B" by auto
  then show "x ∈∘ A ×∘ B" unfolding x_def by simp
qed

lemma (in vbrelation) vlrestriction_vsubset_vrange[intro, simp]:
  assumes "𝒟∘ r ⊆∘ A"
  shows "r ↾l∘ A = r"
proof(intro vsubset_antisym)
  show "r ⊆∘ r ↾l∘ A"
    by (rule vlrestriction_mono[OF assms, of r, unfolded vlrestriction_vdomain])
qed auto

lemma (in vbrelation) vrrestriction_vsubset_vrange[intro, simp]:
  assumes "ℛ∘ r ⊆∘ B"
  shows "r ↾r∘ B = r"
proof(intro vsubset_antisym)
  show "r ⊆∘ r ↾r∘ B"
    by (rule vrrestriction_mono[OF assms, of r, unfolded vrrestriction_vrange])
qed auto

lemma (in vbrelation) vbrelation_vcomp_vid_on_left[simp]:
  assumes "ℛ∘ r ⊆∘ A"
  shows "vid_on A ∘∘ r = r"
  using assms by auto

lemma (in vbrelation) vbrelation_vcomp_vid_on_right[simp]:
  assumes "𝒟∘ r ⊆∘ A"
  shows "r ∘∘ vid_on A = r"
  using assms by auto


text‹Alternative forms of existing results.›

lemmas [intro, simp] = vbrelation.vconverse_vconverse
  and [intro, simp] = vbrelation.vlrestriction_vsubset_vrange
  and [intro, simp] = vbrelation.vrrestriction_vsubset_vrange



subsubsection‹Simple single-valued relation›

locale vsv = vbrelation r for r + 
  assumes vsv: "⟦ ⟨a, b⟩ ∈∘ r; ⟨a, c⟩ ∈∘ r ⟧ ⟹ b = c"


text‹Rules.›

lemmas (in vsv) [intro] = vsv_axioms

mk_ide rf vsv_def[unfolded vsv_axioms_def]
  |intro vsvI[intro]| 
  |dest vsvD[dest]|
  |elim vsvE[elim]|


text‹Set operations.›

lemma (in vsv) vsv_vinsert[simp]:
  assumes "a ∉∘ 𝒟∘ r"
  shows "vsv (vinsert ⟨a, b⟩ r)" 
  using assms vsv_axioms by blast

lemma vsv_vinsertD:
  assumes "vsv (vinsert x r)"
  shows "vsv r"
  using assms by (intro vsvI) auto

lemma vsv_vunion[intro, simp]:
  assumes "vsv r" and "vsv s" and "vdisjnt (𝒟∘ r) (𝒟∘ s)"
  shows "vsv (r ∪∘ s)"
proof
  from assms have F: "⟦ ⟨a, b⟩ ∈∘ r; ⟨a, c⟩ ∈∘ s ⟧ ⟹ False" for a b c
    using elts_0 by blast
  fix a b c assume "⟨a, b⟩ ∈∘ r ∪∘ s" and "⟨a, c⟩ ∈∘ r ∪∘ s" 
  then consider 
      "⟨a, b⟩ ∈∘ r ∧ ⟨a, c⟩ ∈∘ r"
    | "⟨a, b⟩ ∈∘ r ∧ ⟨a, c⟩ ∈∘ s"
    | "⟨a, b⟩ ∈∘ s ∧ ⟨a, c⟩ ∈∘ r"
    | "⟨a, b⟩ ∈∘ s ∧ ⟨a, c⟩ ∈∘ s"
    by blast
  then show "b = c" using assms by cases auto
qed (use assms in auto) 

lemma (in vsv) vsv_vintersection[intro, simp]: "vsv (r ∩∘ s)" 
  using vsv_axioms by blast

lemma (in vsv) vsv_vdiff[intro, simp]: "vsv (r -∘ s)" using vsv_axioms by blast


text‹Connections.›

lemma vsv_vempty[simp]: "vsv 0" by auto

lemma vsv_vsingleton[simp]: "vsv (set {⟨a, b⟩})" by auto

global_interpretation rel_vsingleton: vsv ‹set {⟨a, b⟩}›
  by (rule vsv_vsingleton)

lemma vsv_vdoubleton: 
  assumes "a ≠ c"
  shows "vsv (set {⟨a, b⟩, ⟨c, d⟩})" 
  using assms by (auto simp: vinsert_set_insert_eq)

lemma vsv_vid_on[simp]: "vsv (vid_on A)" by auto

lemma vsv_vconst_on[simp]: "vsv (vconst_on A c)" by auto

lemma vsv_VLambda[simp]: "vsv (λa∈∘A. f a)" by auto

global_interpretation rel_VLambda: vsv ‹(λa∈∘A. f a)›
  unfolding VLambda_def by (intro vsvI) auto

lemma vsv_vcomp: 
  assumes "vsv r" and "vsv s"
  shows "vsv (r ∘∘ s)" 
  using assms
  by (intro vsvI; elim vsvE) (simp add: vbrelation_vcomp, metis vcompD)

lemma (in vsv) vsv_vlrestriction[intro, simp]: "vsv (r ↾l∘ A)" 
  using vsv_axioms by blast

lemma (in vsv) vsv_vrrestriction[intro, simp]: "vsv (r ↾r∘ A)" 
  using vsv_axioms by blast

lemma (in vsv) vsv_vrestriction[intro, simp]: "vsv (r ↾∘ A)" 
  using vsv_axioms by blast


text‹Special properties.›

lemma small_vsv[simp]: "small {f. vsv f ∧ 𝒟∘ f = A ∧ ℛ∘ f ⊆∘ B}"
proof-
  have "small {f. f ⊆∘ A ×∘ B}" by (auto simp: small_iff)
  moreover have "{f. vsv f ∧ 𝒟∘ f = A ∧ ℛ∘ f ⊆∘ B} ⊆ {f. f ⊆∘ A ×∘ B}"
    by auto
  ultimately show "small {f. vsv f ∧ 𝒟∘ f = A ∧ ℛ∘ f ⊆∘ B}" 
    by (auto simp: smaller_than_small)
qed

context vsv
begin

lemma vsv_ex1: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "∃!b. ⟨a, b⟩ ∈∘ r"
  using vsv_axioms assms by auto

lemma vsv_ex1_app1: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "b = r⦇a⦈ ⟷ ⟨a, b⟩ ∈∘ r"
proof 
  assume b_def: "b = r⦇a⦈" show "⟨a, b⟩ ∈∘ r" 
    unfolding app_def b_def by (rule theI') (rule vsv_ex1[OF assms])
next
  assume [simp]: "⟨a, b⟩ ∈∘ r"
  from assms vsv_axioms vsvD have THE_b: "(THE y. ⟨a, y⟩ ∈∘ r) = b" by auto
  show "b = r⦇a⦈" unfolding app_def THE_b[symmetric] by (rule refl)  
qed

lemma vsv_ex1_app2[iff]: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "r⦇a⦈ = b ⟷ ⟨a, b⟩ ∈∘ r"
  using vsv_ex1_app1[OF assms] by auto

lemma vsv_appI[intro, simp]: 
  assumes "⟨a, b⟩ ∈∘ r"
  shows "r⦇a⦈ = b" 
  using assms by (subgoal_tac ‹a ∈∘ 𝒟∘ r›) auto

lemma vsv_appE:
  assumes "r⦇a⦈ = b" and "a ∈∘ 𝒟∘ r" and "⟨a, b⟩ ∈∘ r ⟹ P"
  shows P
  using assms vsv_ex1_app1 by blast

lemma vdomain_vrange_is_vempty: "𝒟∘ r = 0 ⟷ ℛ∘ r = 0" by fastforce

lemma vsv_vrange_vempty: 
  assumes "ℛ∘ r = 0"
  shows "r = 0"
  using assms vdomain_vrange_is_vempty vlrestriction_vdomain by auto

lemma vsv_vdomain_vempty_vrange_vempty:
  assumes "𝒟∘ r ≠ 0"
  shows "ℛ∘ r ≠ 0"
  using assms by fastforce

lemma vsv_vdomain_vsingleton_vrange_vsingleton:
  assumes "𝒟∘ r = set {a}"
  obtains b where "ℛ∘ r = set {b}"
proof-
  from assms obtain b where ab: "⟨a, b⟩ ∈∘ r" by auto
  then have "⟨a, c⟩ ∈∘ r ⟹ c = b" for c by (auto simp: vsv)
  moreover with assms have "⟨b, c⟩ ∈∘ r ⟹ c = a" for c by force
  ultimately have "⟨c, d⟩ ∈∘ r ⟹ d = b" for c d
    by (metis app_vdomainI assms vsingletonD)
  with ab have "ℛ∘ r = set {b}" by blast
  with that show ?thesis by simp
qed

lemma vsv_vsubset_vimageE:
  assumes "B ⊆∘ r `∘ A"
  obtains C where "C ⊆∘ A" and "B = r `∘ C"
proof-
  define C where C_def: "C = (r¯∘ `∘ B) ∩∘ A"
  then have "C ⊆∘ A" by auto
  moreover have "B = r `∘ C"
    unfolding C_def
  proof(intro vsubset_antisym vsubsetI)
    fix b assume "b ∈∘ B"
    with assms obtain a where "a ∈∘ A" and "⟨a, b⟩ ∈∘ r" 
      using app_vimageE vsubsetD by metis
    then have "a ∈∘ r¯∘ `∘ B ∩∘ A" by (auto simp: ‹b ∈∘ B›)
    then show "b ∈∘ r `∘ (r¯∘ `∘ B ∩∘ A)" by (auto intro: ‹⟨a, b⟩ ∈∘ r›)
  qed (use vsv_axioms in auto)
  ultimately show ?thesis using that by auto
qed

lemma vsv_vimage_eqI[intro]:
  assumes "a ∈∘ 𝒟∘ r" and "r⦇a⦈ = b" and "a ∈∘ A"
  shows "b ∈∘ r `∘ A"
  using assms(2)[unfolded vsv_ex1_app2[OF assms(1)]] assms(3) by auto

lemma vsv_vimageI1: 
  assumes "a ∈∘ 𝒟∘ r" and "a ∈∘ A" 
  shows "r⦇a⦈ ∈∘ r `∘ A"
  using assms by (simp add: vsv_vimage_eqI)

lemma vsv_vimageI2: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "r⦇a⦈ ∈∘ ℛ∘ r"
  using assms by (blast dest: vsv_ex1_app1)

lemma vsv_vimageI2':
  assumes "b = r⦇a⦈" and "a ∈∘ 𝒟∘ r"
  shows "b ∈∘ ℛ∘ r"
  using assms by (blast dest: vsv_ex1_app1)

lemma vsv_value: 
  assumes "a ∈∘ 𝒟∘ r"
  obtains b where "r⦇a⦈ = b" and "b ∈∘ ℛ∘ r"
  using assms by (blast dest: vsv_ex1_app1)

lemma vsv_vimageE:
  assumes "b ∈∘ r `∘ A"
  obtains x where "r⦇x⦈ = b" and "x ∈∘ A"
  using assms vsv_axioms vsv_ex1_app2 by blast

lemma vsv_vimage_iff: "b ∈∘ r `∘ A ⟷ (∃a. a ∈∘ A ∧ a ∈∘ 𝒟∘ r ∧ r⦇a⦈ = b)"
  using vsv_axioms by (blast intro: vsv_ex1_app1[THEN iffD1])+

lemma vsv_vimage_vsingleton:
  assumes "a ∈∘ 𝒟∘ r"
  shows "r `∘ set {a} = set {r⦇a⦈}"
  using assms by force

lemma vsv_vimage_vsubsetI: 
  assumes "⋀a. ⟦ a ∈∘ A; a ∈∘ 𝒟∘ r ⟧ ⟹ r⦇a⦈ ∈∘ B" 
  shows "r `∘ A ⊆∘ B"
  using assms by (metis vsv_vimage_iff vsubsetI)

lemma vsv_image_vsubset_iff: 
  "r `∘ A ⊆∘ B ⟷ (∀a∈∘A. a ∈∘ 𝒟∘ r ⟶ r⦇a⦈ ∈∘ B)"
  by (auto simp: vsv_vimage_iff)

lemma vsv_vimage_vinsert:
  assumes "a ∈∘ 𝒟∘ r"
  shows "r `∘ vinsert a A = vinsert (r⦇a⦈) (r `∘ A)"
  using assms vsv_vimage_iff by (intro vsubset_antisym vsubsetI) auto  

lemma vsv_vinsert_vimage[intro, simp]: 
  assumes "a ∈∘ 𝒟∘ r" and "a ∈∘ A" 
  shows "vinsert (r⦇a⦈) (r `∘ A) = r `∘ A"
  using assms by auto

lemma vsv_is_VLambda[simp]: "(λx∈∘𝒟∘ r. r⦇x⦈) = r"
  using vbrelation 
  by (auto simp: app_vdomainI VLambda_iff2 intro!: vsubset_antisym)

lemma vsv_is_VLambda_on_vlrestriction[intro, simp]: 
  assumes "A ⊆∘ 𝒟∘ r"
  shows "(λx∈∘A. r⦇x⦈) = r ↾l∘ A"
  using assms by (force simp: VLambda_iff2)+

lemma pairwise_vimageI:
  assumes "⋀x y. 
    ⟦ x ∈∘ 𝒟∘ r; y ∈∘ 𝒟∘ r; x ≠ y; r⦇x⦈ ≠ r⦇y⦈ ⟧ ⟹ P (r⦇x⦈) (r⦇y⦈)"
  shows "vpairwise P (ℛ∘ r)"
  by (intro vpairwiseI) (metis assms app_vdomainI app_vrangeE vsv_appI)

lemma vsv_vrange_vsubset:
  assumes "⋀x. x ∈∘ 𝒟∘ r ⟹ r⦇x⦈ ∈∘ A"
  shows "ℛ∘ r ⊆∘ A"
  using assms by fastforce

lemma vsv_vlrestriction_vinsert:
  assumes "a ∈∘ 𝒟∘ r"
  shows "r ↾l∘ vinsert a A = vinsert ⟨a, r⦇a⦈⟩ (r ↾l∘ A)"  
  using assms by (auto intro!: vsubset_antisym)

end

lemma vsv_eqI: 
  assumes "vsv r" 
    and "vsv s"
    and "𝒟∘ r = 𝒟∘ s" 
    and "⋀a. a ∈∘ 𝒟∘ r ⟹ r⦇a⦈ = s⦇a⦈"
  shows "r = s"
proof(intro vsubset_antisym vsubsetI)
  interpret r: vsv r by (rule assms(1))
  interpret s: vsv s by (rule assms(2))
  fix x assume "x ∈∘ r"
  then obtain a b where x_def[simp]: "x = ⟨a, b⟩" and "a ∈∘ 𝒟∘ r" 
    by (elim r.vbrelation_vinE)
  with ‹x ∈∘ r› have "r⦇a⦈ = b" by simp
  with assms ‹a ∈∘ 𝒟∘ r› show "x ∈∘ s" by fastforce
next
  interpret r: vsv r by (rule assms(1))
  interpret s: vsv s by (rule assms(2))
  fix x assume "x ∈∘ s"
  with assms(2) obtain a b where x_def[simp]: "x = ⟨a, b⟩" and "a ∈∘ 𝒟∘ s" 
    by (elim vsvE) blast
  with assms ‹x ∈∘ s› have "s⦇a⦈ = b" by blast
  with assms ‹a ∈∘ 𝒟∘ s› show "x ∈∘ r" by fastforce
qed

lemma (in vsv) vsv_VLambda_cong: 
  assumes "⋀a. a ∈∘ 𝒟∘ r ⟹ r⦇a⦈ = f a"
  shows "(λa∈∘𝒟∘ r. f a) = r"
proof(rule vsv_eqI[symmetric])
  show "𝒟∘ r = 𝒟∘ (VLambda (𝒟∘ r) f)" by simp
  fix a assume a: "a ∈∘ 𝒟∘ r"
  then show "r⦇a⦈ = VLambda (𝒟∘ r) f ⦇a⦈" using assms(1)[OF a] by auto
qed auto

lemma Axiom_of_Choice:
  obtains f where "⋀x. x ∈∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈∘ x" and "vsv f"
proof-
  obtain f where f: "x ∈∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈∘ x" for x
    by (metis beta vemptyE)
  define f' where "f' = (λx∈∘A. f⦇x⦈)"
  have "x ∈∘ A ⟹ x ≠ 0 ⟹ f'⦇x⦈ ∈∘ x" for x
    unfolding f'_def using f by simp
  moreover have "vsv f'" unfolding f'_def by simp
  ultimately show ?thesis using that by auto
qed

lemma VLambda_eqI:
  assumes "X = Y" and "⋀x. x ∈∘ X ⟹ f x = g x"
  shows "(λx∈∘X. f x) = (λy∈∘Y. g y)"
proof(rule vsv_eqI, unfold vdomain_VLambda; (intro assms(1) vsv_VLambda)?)
  fix x assume "x ∈∘ X"
  with assms show "VLambda X f⦇x⦈ = VLambda Y g⦇x⦈" by simp
qed

lemma VLambda_vsingleton_def: "(λi∈∘set {j}. f i) = (λi∈∘set {j}. f j)" by auto


text‹Alternative forms of the available results.›

lemmas [iff] = vsv.vsv_ex1_app2
  and [intro, simp] = vsv.vsv_appI
  and [elim] = vsv.vsv_appE
  and [intro] = vsv.vsv_vimage_eqI
  and [simp] = vsv.vsv_vinsert_vimage
  and [intro] = vsv.vsv_is_VLambda_on_vlrestriction
  and [simp] = vsv.vsv_is_VLambda
  and [intro, simp] = vsv.vsv_vintersection
  and [intro, simp] = vsv.vsv_vdiff
  and [intro, simp] = vsv.vsv_vlrestriction
  and [intro, simp] = vsv.vsv_vrrestriction
  and [intro, simp] = vsv.vsv_vrestriction


subsubsection‹Specialization of existing properties to single-valued relations.›


text‹Identity relation.›

lemma vid_on_eq_atI[intro, simp]: 
  assumes "a = b" and "a ∈∘ A"
  shows "vid_on A ⦇a⦈ = b"
  using assms by auto

lemma vid_on_atI[intro, simp]: 
  assumes "a ∈∘ A"
  shows "vid_on A ⦇a⦈ = a"
  using assms by auto

lemma vid_on_at_iff[intro, simp]:
  assumes "a ∈∘ A"
  shows "vid_on A ⦇a⦈ = b ⟷ a = b" 
  using assms by auto


text‹Constant function.›

lemma vconst_on_atI[simp]: 
  assumes "a ∈∘ A"
  shows "vconst_on A c ⦇a⦈ = c"
  using assms by auto


text‹Composition.›

lemma vcomp_atI[intro, simp]: 
  assumes "vsv r" 
    and "vsv s" 
    and "a ∈∘ 𝒟∘ r" 
    and "b ∈∘ 𝒟∘ s" 
    and "s⦇b⦈ = c" 
    and "r⦇a⦈ = b" 
  shows "(s ∘∘ r)⦇a⦈ = c"
  using assms by (auto simp: app_invimageI intro!: vsv_vcomp)

lemma vcomp_atD[dest]: 
  assumes "(s ∘∘ r)⦇a⦈ = c"
    and "vsv r" 
    and "vsv s"  
    and "a ∈∘ 𝒟∘ r" 
    and "r⦇a⦈ ∈∘ 𝒟∘ s" 
  shows "∃b. s⦇b⦈ = c ∧ r⦇a⦈ = b" 
  using assms by (metis vcomp_atI)

lemma vcomp_atE1: 
  assumes "(s ∘∘ r)⦇a⦈ = c"
    and "vsv r" 
    and "vsv s" 
    and "a ∈∘ 𝒟∘ r"
    and "r⦇a⦈ ∈∘ 𝒟∘ s"
    and "∃b. s⦇b⦈ = c ∧ r⦇a⦈ = b ⟹ P"  
  shows P
  using assms assms vcomp_atD by blast

lemma vcomp_atE[elim]:
  assumes "(s ∘∘ r)⦇a⦈ = c"
    and "vsv r" 
    and "vsv s"  
    and "a ∈∘ 𝒟∘ r" 
    and "r⦇a⦈ ∈∘ 𝒟∘ s"
  obtains b where "r⦇a⦈ = b" and "s⦇b⦈ = c"
  using assms that by (force elim!: vcomp_atE1)

lemma vsv_vcomp_at[simp]:
  assumes "vsv r" and "vsv s" and "a ∈∘ 𝒟∘ r" and "r⦇a⦈ ∈∘ 𝒟∘ s"
  shows "(s ∘∘ r)⦇a⦈ = s⦇r⦇a⦈⦈"
  using assms by auto

context vsv
begin


text‹Converse relation.›

lemma vconverse_atI[intro]: 
  assumes "a ∈∘ 𝒟∘ r" and "r⦇a⦈ = b" 
  shows "⟨b, a⟩ ∈∘ r¯∘"
  using assms by auto

lemma vconverse_atD[dest]: 
  assumes "⟨b, a⟩ ∈∘ r¯∘"
  shows "r⦇a⦈ = b" 
  using assms by auto

lemma vconverse_atE[elim]: 
  assumes "⟨b, a⟩ ∈∘ r¯∘" and "r⦇a⦈ = b ⟹ P" 
  shows P
  using assms by auto

lemma vconverse_iff: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "⟨b, a⟩ ∈∘ r¯∘ ⟷ r⦇a⦈ = b" 
  using assms by auto


text‹Left restriction.›

interpretation vlrestriction: vsv ‹r ↾l∘ A› by (rule vsv_vlrestriction)

lemma vlrestriction_atI[intro, simp]: 
  assumes "a ∈∘ 𝒟∘ r" and "a ∈∘ A" and "r⦇a⦈ = b" 
  shows "(r ↾l∘ A)⦇a⦈ = b"
  using assms by (auto simp: vdomain_vlrestriction)

lemma vlrestriction_atD[dest]: 
  assumes "(r ↾l∘ A)⦇a⦈ = b" and "a ∈∘ 𝒟∘ r" and "a ∈∘ A"
  shows "r⦇a⦈ = b"
  using assms by (auto simp: vdomain_vlrestriction)

lemma vlrestriction_atE1[elim]: 
  assumes "(r ↾l∘ A)⦇a⦈ = b" 
    and "a ∈∘ 𝒟∘ r"
    and "a ∈∘ A"
    and "r⦇a⦈ = b ⟹ P"
  shows P
  using assms vlrestrictionD by blast

lemma vlrestriction_atE2[elim]: 
  assumes "x ∈∘ r ↾l∘ A"
  obtains a b where "x = ⟨a, b⟩" and "a ∈∘ A" and "r⦇a⦈ = b"
  using assms by auto


text‹Right restriction.›

interpretation vrrestriction: vsv ‹r ↾r∘ A› by (rule vsv_vrrestriction)

lemma vrrestriction_atI[intro, simp]: 
  assumes "a ∈∘ 𝒟∘ r" and "b ∈∘ A" and "r⦇a⦈ = b" 
  shows "(r ↾r∘ A)⦇a⦈ = b" 
  using assms by (auto simp: app_vrrestrictionI)

lemma vrrestriction_atD[dest]: 
  assumes "(r ↾r∘ A)⦇a⦈ = b" and "a ∈∘ r -`∘ A"
  shows "b ∈∘ A" and "r⦇a⦈ = b"
  using assms by force+

lemma vrrestriction_atE1[elim]: 
  assumes "(r ↾r∘ A)⦇a⦈ = b" and "a ∈∘ r -`∘ A" and "r⦇a⦈ = b ⟹ P"
  shows P
  using assms by (auto simp: vrrestriction_atD(2))

lemma vrrestriction_atE2[elim]:
  assumes "x ∈∘ r ↾r∘ A"
  obtains a b where "x = ⟨a, b⟩" and "b ∈∘ A" and "r⦇a⦈ = b"
  using assms unfolding vrrestriction_def by auto


text‹Restriction.›

interpretation vrestriction: vsv ‹r ↾∘ A› by (rule vsv_vrestriction)

lemma vlrestriction_app[intro, simp]: 
  assumes "a ∈∘ 𝒟∘ r" and "a ∈∘ A"
  shows "(r ↾l∘ A)⦇a⦈ = r⦇a⦈"
  using assms by auto

lemma vrestriction_atD[dest]:
  assumes "(r ↾∘ A)⦇a⦈ = b" and "a ∈∘ r -`∘ A" and "a ∈∘ A"
  shows "b ∈∘ A" and "r⦇a⦈ = b"
proof-
  from assms have "a ∈∘ 𝒟∘ r" by auto
  then show "r⦇a⦈ = b"  
    by 
      (
        metis 
          assms 
          app_invimageD1 
          vrrestriction.vlrestriction_atD 
          vrrestriction_atD(2) 
          vrrestriction_vlrestriction
      )
  then show "b ∈∘ A" using assms(2) by blast
qed
 
lemma vrestriction_atE1[elim]: 
  assumes "(r ↾∘ A)⦇a⦈ = b" 
    and "a ∈∘ r -`∘ A" 
    and "a ∈∘ A" 
    and "r⦇a⦈ = b ⟹ P"
  shows P
  using assms vrestriction_atD(2) by blast

lemma vrestriction_atE2[elim]:
  assumes "x ∈∘ r ↾∘ A"
  obtains a b where "x = ⟨a, b⟩" and "a ∈∘ A" and "b ∈∘ A" and "r⦇a⦈ = b"
  using assms unfolding vrestriction_def by clarsimp


text‹Domain.›

lemma vdomain_atD: 
  assumes "a ∈∘ 𝒟∘ r"
  shows "∃b∈∘ℛ∘ r. r⦇a⦈ = b" 
  using assms by (blast intro: vsv_vimageI2)

lemma vdomain_atE:
  assumes "a ∈∘ 𝒟∘ r" 
  obtains b where "b ∈∘ ℛ∘ r" and "r⦇a⦈ = b"
  using assms by auto


text‹Range.›

lemma vrange_atD: 
  assumes "b ∈∘ ℛ∘ r"
  shows "∃a∈∘𝒟∘ r. r⦇a⦈ = b" 
  using assms by auto

lemma vrange_atE:
  assumes "b ∈∘ ℛ∘ r" 
  obtains a where "a ∈∘ 𝒟∘ r" and "r⦇a⦈ = b"
  using assms by auto


text‹Image.›

lemma vimage_set_eq_at: 
  "{b. ∃a∈∘A ∩∘ 𝒟∘ r. r⦇a⦈ = b} = {b. ∃a∈∘A. ⟨a, b⟩ ∈∘ r}"
  by (rule subset_antisym; rule subsetI; unfold mem_Collect_eq) auto

lemma vimage_small[simp]: "small {b. ∃a∈∘A ∩∘ 𝒟∘ r. r⦇a⦈ = b}"
  unfolding vimage_set_eq_at by auto

lemma vimage_set_def: "r `∘ A = set {b. ∃a∈∘A ∩∘ 𝒟∘ r. r⦇a⦈ = b}"
  unfolding vimage_set_eq_at by (simp add: app_vimage_set_def)

lemma vimage_set_iff: "b ∈∘ r `∘ A ⟷ (∃a∈∘A ∩∘ 𝒟∘ r. r⦇a⦈ = b)"
  unfolding vimage_set_eq_at using vsv_vimage_iff by auto


text‹Further derived results.›

lemma vimage_image:
  assumes "A ⊆∘ 𝒟∘ r"
  shows "elts (r `∘ A) = (λx. r⦇x⦈) ` (elts A)"
  using vimage_def assms small_elts by blast

lemma vsv_vinsert_match_appI[intro, simp]:
  assumes "a ∉∘ 𝒟∘ r" 
  shows "vinsert ⟨a, b⟩ r ⦇a⦈ = b" 
  using assms vsv_axioms by simp

lemma vsv_vinsert_no_match_appI:
  assumes "a ∉∘ 𝒟∘ r" and "c ∈∘ 𝒟∘ r" and "r ⦇c⦈ = d" 
  shows "vinsert ⟨a, b⟩ r ⦇c⦈ = d" 
  using assms vsv_axioms by simp

lemma vsv_is_vconst_onI:
  assumes "𝒟∘ r = A" and "ℛ∘ r = set {a}"
  shows "r = vconst_on A a"
  unfolding assms(1)[symmetric]
proof(cases ‹𝒟∘ r = 0›)
  case True
  with assms show "r = vconst_on (𝒟∘ r) a" 
    by (auto simp: vdomain_vrange_is_vempty)
next
  case False
  show "r = vconst_on (𝒟∘ r) a"
  proof(rule vsv_eqI)
    fix a' assume prems: "a' ∈∘ 𝒟∘ r"
    then obtain b where "r⦇a'⦈ = b" and "b ∈∘ ℛ∘ r" by auto
    moreover then have "b = a" unfolding assms by simp
    ultimately show "r⦇a'⦈ = vconst_on (𝒟∘ r) a⦇a'⦈" by (simp add: prems)
  qed auto
qed

lemma vsv_vdomain_vrange_vsingleton:
  assumes "𝒟∘ r = set {a}" and "ℛ∘ r = set{b}"
  shows "r = set {⟨a, b⟩}"
  using assms vsv_is_vconst_onI by auto

end


text‹Alternative forms of existing results.›

lemmas [intro] = vsv.vconverse_atI
  and vsv_vconverse_atD[dest] = vsv.vconverse_atD[rotated]
  and vsv_vconverse_atE[elim] = vsv.vconverse_atE[rotated]
  and [intro, simp] = vsv.vlrestriction_atI
  and vsv_vlrestriction_atD[dest] = vsv.vlrestriction_atD[rotated]
  and vsv_vlrestriction_atE1[elim] = vsv.vlrestriction_atE1[rotated]
  and vsv_vlrestriction_atE2[elim] = vsv.vlrestriction_atE2[rotated]
  and [intro, simp] = vsv.vrrestriction_atI
  and vsv_vrrestriction_atD[dest] = vsv.vrrestriction_atD[rotated]
  and vsv_vrrestriction_atE1[elim] = vsv.vrrestriction_atE1[rotated]
  and vsv_vrrestriction_atE2[elim] = vsv.vrrestriction_atE2[rotated]
  and [intro, simp] = vsv.vlrestriction_app
  and vsv_vrestriction_atD[dest] = vsv.vrestriction_atD[rotated]
  and vsv_vrestriction_atE1[elim] = vsv.vrestriction_atE1[rotated]
  and vsv_vrestriction_atE2[elim] = vsv.vrestriction_atE2[rotated]
  and vsv_vdomain_atD = vsv.vdomain_atD[rotated]
  and vsv_vdomain_atE = vsv.vdomain_atE[rotated]
  and vrange_atD = vsv.vrange_atD[rotated]
  and vrange_atE = vsv.vrange_atE[rotated]
  and vsv_vinsert_match_appI[intro, simp] = vsv.vsv_vinsert_match_appI 
  and vsv_vinsert_no_match_appI[intro, simp] = 
    vsv.vsv_vinsert_no_match_appI[rotated 3]


text‹Corollaries of the alternative forms of existing results.›

lemma vsv_vlrestriction_vrange:
  assumes "vsv s" and "vsv (r ↾l∘ ℛ∘ s)"
  shows "vsv (r ∘∘ s)"
proof(rule vsvI)
  show "vbrelation (r ∘∘ s)" by auto
  fix a c c' assume "⟨a, c⟩ ∈∘ r ∘∘ s" "⟨a, c'⟩ ∈∘ r ∘∘ s"
  then obtain b and b' 
    where ab: "⟨a, b⟩ ∈∘ s" 
      and bc: "⟨b, c⟩ ∈∘ r"
      and ab': "⟨a, b'⟩ ∈∘ s" 
      and b'c': "⟨b', c'⟩ ∈∘ r"
    by clarsimp
  moreover then have "b ∈∘ ℛ∘ s" and "b' ∈∘ ℛ∘ s" by auto
  ultimately have "⟨b, c⟩ ∈∘ (r ↾l∘ ℛ∘ s)" and "⟨b', c'⟩ ∈∘ (r ↾l∘ ℛ∘ s)" by auto
  with ab ab' have "⟨a, c⟩ ∈∘ (r ↾l∘ ℛ∘ s) ∘∘ s" and "⟨a, c'⟩ ∈∘ (r ↾l∘ ℛ∘ s) ∘∘ s"
    by blast+
  moreover from assms have "vsv ((r ↾l∘ ℛ∘ s) ∘∘ s)" by (intro vsv_vcomp)
  ultimately show "c = c'" by auto
qed

lemma vsv_vunion_app_right[simp]:
  assumes "vsv r" and "vsv s" and "vdisjnt (𝒟∘ r) (𝒟∘ s)" and "x ∈∘ 𝒟∘ s"
  shows "(r ∪∘ s)⦇x⦈ = s⦇x⦈"
  using assms vsubsetD by blast  

lemma vsv_vunion_app_left[simp]:
  assumes "vsv r" and "vsv s" and "vdisjnt (𝒟∘ r) (𝒟∘ s)" and "x ∈∘ 𝒟∘ r"
  shows "(r ∪∘ s)⦇x⦈ = r⦇x⦈"
  using assms vsubsetD by blast  


subsubsection‹One-to-one relation›

locale v11 = vsv r for r +
  assumes vsv_vconverse: "vsv (r¯∘)"


text‹Rules.›

lemmas (in v11) [intro] = v11_axioms

mk_ide rf v11_def[unfolded v11_axioms_def]
  |intro v11I[intro]| 
  |dest v11D[dest]|
  |elim v11E[elim]|


text‹Set operations.›

lemma (in v11) v11_vinsert[intro, simp]:
  assumes "a ∉∘ 𝒟∘ r" and "b ∉∘ ℛ∘ r"
  shows "v11 (vinsert ⟨a, b⟩ r)" 
  using assms v11_axioms 
  by (intro v11I; elim v11E) (simp_all add: vconverse_vinsert vsv.vsv_vinsert)

lemma v11_vinsertD:
  assumes "v11 (vinsert x r)"
  shows "v11 r"
  using assms by (intro v11I) (auto simp: vsv_vinsertD)

lemma v11_vunion:
  assumes "v11 r" 
    and "v11 s" 
    and "vdisjnt (𝒟∘ r) (𝒟∘ s)" 
    and "vdisjnt (ℛ∘ r) (ℛ∘ s)"
  shows "v11 (r ∪∘ s)"
proof
  interpret r: v11 r by (rule assms(1))
  interpret s: v11 s by (rule assms(2))
  show "vsv (r ∪∘ s)" by (simp add: assms v11D)
  from assms show "vsv ((r ∪∘ s)¯∘)"
    by (simp add: assms r.vsv_vconverse s.vsv_vconverse vconverse_vunion)
qed

lemma (in v11) v11_vintersection[intro, simp]: "v11 (r ∩∘ s)"
  using v11_axioms by (intro v11I) auto

lemma (in v11) v11_vdiff[intro, simp]: "v11 (r -∘ s)"
  using v11_axioms by (intro v11I) auto


text‹Special properties.›

lemma (in vsv) vsv_valneq_v11I:
  assumes "⋀x y. ⟦ x ∈∘ 𝒟∘ r; y ∈∘ 𝒟∘ r; x ≠ y ⟧ ⟹ r⦇x⦈ ≠ r⦇y⦈"
  shows "v11 r"
proof(intro v11I)
  from vsv_axioms show "vsv r" by simp
  show "vsv (r¯∘)"
    by 
      (
        metis
          assms 
          vbrelation_vconverse 
          vconverse_atD 
          app_vrangeI 
          vrange_vconverse 
          vsvI
      )
qed

lemma (in vsv) vsv_valeq_v11I:
  assumes "⋀x y. ⟦ x ∈∘ 𝒟∘ r; y ∈∘ 𝒟∘ r; r⦇x⦈ = r⦇y⦈ ⟧ ⟹ x = y"
  shows "v11 r"
  using assms vsv_valneq_v11I by auto


text‹Connections.›

lemma v11_vempty[simp]: "v11 0" by (simp add: v11I)

lemma v11_vsingleton[simp]: "v11 (set {⟨a, b⟩})" by auto

lemma v11_vdoubleton: 
  assumes "a ≠ c" and "b ≠ d"
  shows "v11 (set {⟨a, b⟩, ⟨c, d⟩})" 
  using assms by (auto simp: vinsert_set_insert_eq)

lemma v11_vid_on[simp]: "v11 (vid_on A)" by auto

lemma v11_VLambda[intro]:
  assumes "inj_on f (elts A)"
  shows "v11 (λa∈∘A. f a)"
proof(rule rel_VLambda.vsv_valneq_v11I)
  fix x y 
  assume "x ∈∘ 𝒟∘ (λa∈∘A. f a)" and "y ∈∘ 𝒟∘ (λa∈∘A. f a)" and "x ≠ y"
  then have "x ∈∘ A" and "y ∈∘ A" by auto
  with assms ‹x ≠ y› have "f x ≠ f y" by (auto dest: inj_onD)
  then show "(λa∈∘A. f a)⦇x⦈ ≠ (λa∈∘A. f a)⦇y⦈" 
    by (simp add: ‹x ∈∘ A› ‹y ∈∘ A›)
qed

lemma v11_vcomp:  
  assumes "v11 r" and "v11 s"
  shows "v11 (r ∘∘ s)"
  using assms by (intro v11I; elim v11E) (auto simp: vsv_vcomp vconverse_vcomp)

context v11
begin

lemma v11_vconverse: "v11 (r¯∘)" by (auto simp: vsv_axioms vsv_vconverse)

interpretation v11 ‹r¯∘› by (rule v11_vconverse)

lemma v11_vlrestriction[intro, simp]: "v11 (r ↾l∘ A)"
  using vsv_vrrestriction by (auto simp: vrrestriction_vconverse)

lemma v11_vrrestriction[intro, simp]: "v11 (r ↾r∘ A)"
  using vsv_vlrestriction by (auto simp: vlrestriction_vconverse)

lemma v11_vrestriction[intro, simp]: "v11 (r ↾∘ A)"
  using vsv_vrestriction by (auto simp: vrestriction_vconverse)

end


text‹Further Special properties.›

context v11
begin

lemma v11_injective: 
  assumes "a ∈∘ 𝒟∘ r" and "b ∈∘ 𝒟∘ r" and "r⦇a⦈ = r⦇b⦈" 
  shows "a = b"
  using assms v11_axioms by auto

lemma v11_double_pair: 
  assumes "a ∈∘ 𝒟∘ r" and "a' ∈∘ 𝒟∘ r" and "r⦇a⦈ = b" and "r⦇a'⦈ = b'" 
  shows "a = a' ⟷ b = b'"
  using assms v11_axioms by auto

lemma v11_vrange_ex1_eq: "b ∈∘ ℛ∘ r ⟷ (∃!a∈∘𝒟∘ r. r⦇a⦈ = b)"
proof(rule iffI)
  from app_vdomainI v11_injective show 
    "b ∈∘ ℛ∘ r ⟹ ∃!a. a ∈∘ 𝒟∘ r ∧ r⦇a⦈ = b"
    by (elim app_vrangeE) auto
  show "∃!a. a ∈∘ 𝒟∘ r ∧ r⦇a⦈ = b ⟹ b ∈∘ ℛ∘ r"
    by (auto intro: vsv_vimageI2)
qed

lemma v11_VLambda_iff: "inj_on f (elts A) ⟷ v11 (λa∈∘A. f a)"
  by (rule iffI; (intro inj_onI | tactic‹all_tac›)) 
    (auto simp: v11.v11_injective)

lemma v11_vimage_vpsubset_neq:
  assumes "A ⊆∘ 𝒟∘ r" and "B ⊆∘ 𝒟∘ r" and "A ≠ B"
  shows "r `∘ A ≠ r `∘ B" 
proof-
  from assms obtain a where AB: "a ∈∘ A ∨ a ∈∘ B" and nAB: "a ∉∘ A ∨ a ∉∘ B" 
    by auto
  then have "r⦇a⦈ ∉∘ r `∘ A ∨ r⦇a⦈ ∉∘ r `∘ B"
    unfolding vsv_vimage_iff by (metis assms(1,2) v11_injective vsubsetD)
  moreover from AB nAB assms(1,2) have "r⦇a⦈ ∈∘ r `∘ A ∨ r⦇a⦈ ∈∘ r `∘ B"
    by auto
  ultimately show "r `∘ A ≠ r `∘ B" by clarsimp
qed

lemma v11_eq_iff[simp]:
  assumes "a ∈∘ 𝒟∘ r" and "b ∈∘ 𝒟∘ r"
  shows "r⦇a⦈ = r⦇b⦈ ⟷ a = b"
  using assms v11_double_pair by blast

lemma v11_vcomp_vconverse: "r¯∘ ∘∘ r = vid_on (𝒟∘ r)"
proof(intro vsubset_antisym vsubsetI)
  fix x assume prems: "x ∈∘ r¯∘ ∘∘ r"
  then obtain a c where x_def: "x = ⟨a, c⟩" and a: "a ∈∘ 𝒟∘ r" by auto
  with prems obtain b where "⟨a, b⟩ ∈∘ r" and "⟨b, c⟩ ∈∘ r¯∘" by auto
  with v11.vsv_vconverse v11_axioms have ca: "c = a" by auto
  from a show "x ∈∘ vid_on (𝒟∘ r)" unfolding x_def ca by auto
next
  fix x assume "x ∈∘ vid_on (𝒟∘ r)"
  then obtain a where x_def: "x = ⟨a, a⟩" and a: "a ∈∘ 𝒟∘ r" by clarsimp
  then obtain b where "⟨a, b⟩ ∈∘ r" by auto
  then show "x ∈∘ r¯∘ ∘∘ r" unfolding x_def using a by auto
qed

lemma v11_vcomp_vconverse': "r ∘∘ r¯∘ = vid_on (ℛ∘ r)"
  using v11.v11_vcomp_vconverse v11_vconverse by force

lemma v11_vconverse_app[simp]:
  assumes "r⦇a⦈ = b" and "a ∈∘ 𝒟∘ r"
  shows "r¯∘⦇b⦈ = a"
  using assms by (simp add: vsv.vconverse_iff vsv_axioms vsv_vconverse)

lemma v11_vconverse_app_in_vdomain:
  assumes "y ∈∘ ℛ∘ r"
  shows "r¯∘⦇y⦈ ∈∘ 𝒟∘ r"
  using assms v11_vconverse 
  unfolding vrange_vconverse[symmetric] 
  by (auto simp: v11_def)

lemma v11_app_if_vconverse_app:
  assumes "y ∈∘ ℛ∘ r" and "r¯∘⦇y⦈ = x"
  shows "r⦇x⦈ = y"
  using assms vsv_vconverse by auto

lemma v11_app_vconverse_app:
  assumes "a ∈∘ ℛ∘ r"
  shows "r⦇r¯∘⦇a⦈⦈ = a"
  using assms by (meson v11_app_if_vconverse_app)

lemma v11_vconverse_app_app:
  assumes "a ∈∘ 𝒟∘ r"
  shows "r¯∘⦇r⦇a⦈⦈ = a"
  using assms v11_vconverse_app by auto

end

lemma v11_vlrestriction_vsubset:
  assumes "v11 (f ↾l∘ A)" and "B ⊆∘ A"
  shows "v11 (f ↾l∘ B)"
proof-
  from assms have fB_def: "f ↾l∘ B = (f ↾l∘ A) ↾l∘ B" by auto
  show ?thesis unfolding fB_def by (intro v11.v11_vlrestriction assms(1))
qed

lemma v11_vlrestriction_vrange:
  assumes "v11 s" and "v11 (r ↾l∘ ℛ∘ s)"
  shows "v11 (r ∘∘ s)"
proof(intro v11I)
  interpret v11 s by (rule assms(1)) 
  from assms vsv_vlrestriction_vrange show "vsv (r ∘∘ s)"
    by (simp add: v11.axioms(1))
  show "vsv ((r ∘∘ s)¯∘)"
    unfolding vconverse_vcomp
  proof(rule vsvI)
    fix a c c' assume "⟨a, c⟩ ∈∘ s¯∘ ∘∘ r¯∘" "⟨a, c'⟩ ∈∘ s¯∘ ∘∘ r¯∘"
    then obtain b and b' 
      where "⟨b, a⟩ ∈∘ r" 
      and bc: "⟨c, b⟩ ∈∘ s"
      and "⟨b', a⟩ ∈∘ r" 
      and b'c': "⟨c', b'⟩ ∈∘ s"
      by auto
    moreover then have "b ∈∘ ℛ∘ s" and "b' ∈∘ ℛ∘ s" by auto
    ultimately have "⟨b, a⟩ ∈∘ (r ↾l∘ ℛ∘ s)" and "⟨b', a⟩ ∈∘ (r ↾l∘ ℛ∘ s)" by auto
    with assms(2) have bb': "b = b'" by auto
    from assms bc[unfolded bb'] b'c' show "c = c'" by auto
  qed auto
qed

lemma v11_vlrestriction_vcomp:
  assumes "v11 (f ↾l∘ A)" and "v11 (g ↾l∘ (f `∘ A))"
  shows "v11 ((g ∘∘ f) ↾l∘ A)"
  using assms v11_vlrestriction_vrange by (auto simp: assms(2) app_vimage_def)


text‹Alternative forms of existing results.›

lemmas [intro, simp] = v11.v11_vinsert
  and [intro, simp] = v11.v11_vintersection
  and [intro, simp] = v11.v11_vdiff
  and [intro, simp] = v11.v11_vrrestriction
  and [intro, simp] = v11.v11_vlrestriction
  and [intro, simp] = v11.v11_vrestriction
  and [intro] = v11.v11_vimage_vpsubset_neq



subsection‹Tools: ‹mk_VLambda››

ML‹

(* low level unfold *)
(*Designed based on an algorithm from HOL-Types_To_Sets/unoverload_def.ML*)
fun pure_unfold ctxt thms = ctxt
  |> 
    (
      thms
      |> Conv.rewrs_conv 
      |> Conv.try_conv 
      |> K
      |> Conv.top_conv
    )
  |> Conv.fconv_rule;

val msg_args = "mk_VLambda: invalid arguments"

val vsv_VLambda_thm = @{thm vsv_VLambda};
val vsv_VLambda_match = vsv_VLambda_thm 
  |> Thm.full_prop_of
  |> HOLogic.dest_Trueprop
  |> dest_comb 
  |> #2;

val vdomain_VLambda_thm = @{thm vdomain_VLambda};
val vdomain_VLambda_match = vdomain_VLambda_thm 
  |> Thm.full_prop_of
  |> HOLogic.dest_Trueprop
  |> HOLogic.dest_eq
  |> #1
  |> dest_comb
  |> #2;

val app_VLambda_thm = @{thm ZFC_Cardinals.beta};
val app_VLambda_match = app_VLambda_thm 
  |> Thm.concl_of
  |> HOLogic.dest_Trueprop
  |> HOLogic.dest_eq
  |> #1
  |> strip_comb
  |> #2
  |> hd;

fun mk_VLabmda_thm match_t match_thm ctxt thm =
  let
    val thm_ct = Thm.cprop_of thm
    val (_, rhs_ct) = Thm.dest_equals thm_ct
      handle TERM ("dest_equals", _) => error msg_args
    val insts = Thm.match (Thm.cterm_of ctxt match_t, rhs_ct)
      handle Pattern.MATCH => error msg_args
  in 
    match_thm
    |> Drule.instantiate_normalize insts
    |> pure_unfold ctxt (thm |> Thm.symmetric |> single) 
  end;

val mk_VLambda_vsv =
  mk_VLabmda_thm vsv_VLambda_match vsv_VLambda_thm;
val mk_VLambda_vdomain =
  mk_VLabmda_thm vdomain_VLambda_match vdomain_VLambda_thm;
val mk_VLambda_app = 
  mk_VLabmda_thm app_VLambda_match app_VLambda_thm;

val mk_VLambda_parser = Parse.thm --
  (
    Scan.repeat
      (
        (keyword‹|vsv› -- Parse_Spec.opt_thm_name "|") ||
        (keyword‹|app› -- Parse_Spec.opt_thm_name "|") ||
        (keyword‹|vdomain› -- Parse_Spec.opt_thm_name "|")
      )
  );

fun process_mk_VLambda_thm mk_VLambda_thm (b, thm) ctxt =
  let 
    val thm' = mk_VLambda_thm ctxt thm
    val ((c, thms'), ctxt') = ctxt
      |> Local_Theory.note (b ||> map (Attrib.check_src ctxt), single thm') 
    val _ = IDE_Utilities.thm_printer ctxt' true c thms'
  in ctxt' end;

fun folder_mk_VLambda (("|vsv", b), thm) ctxt =
      process_mk_VLambda_thm mk_VLambda_vsv (b, thm) ctxt
  | folder_mk_VLambda (("|app", b), thm) ctxt =
      process_mk_VLambda_thm mk_VLambda_app (b, thm) ctxt
  | folder_mk_VLambda (("|vdomain", b), thm) ctxt =
      process_mk_VLambda_thm mk_VLambda_vdomain (b, thm) ctxt
  | folder_mk_VLambda _ _ = error msg_args

fun process_mk_VLambda (thm, ins) ctxt =
  let
    val _ = ins |> map fst |> has_duplicates op= |> not orelse error msg_args
    val thm' = thm
      |> singleton (Attrib.eval_thms ctxt)
      |> Local_Defs.meta_rewrite_rule ctxt;
  in fold folder_mk_VLambda (map (fn x => (x, thm')) ins) ctxt end;

val _ =
  Outer_Syntax.local_theory
    command_keyword‹mk_VLambda›
    "VLambda"
    (mk_VLambda_parser >> process_mk_VLambda);

›

text‹\newpage›

end

Theory CZH_Sets_IF

(* Copyright 2021 (C) Mihails Milehins *)

section‹Operations on indexed families of sets›
theory CZH_Sets_IF
  imports CZH_Sets_BRelations
begin



subsection‹Background›


text‹
This section presents results about the fundamental operations on the indexed
families of sets, such as unions and intersections of the indexed families
of sets, disjoint unions and infinite Cartesian products.

Certain elements of the content of this section were inspired by
elements of the content of \cite{paulson_hereditarily_2013}. 
However, as previously, many other results were ported (with amendments) from 
the main library of Isabelle/HOL.
›

abbreviation (input) imVLambda :: "V ⇒ (V ⇒ V) ⇒ V"
  where "imVLambda A f ≡ (λa∈∘A. f a) `∘ A"



subsection‹Intersection of an indexed family of sets›

syntax "_VIFINTER" :: "pttrn ⇒ V ⇒ V ⇒ V"  (‹(3⋂∘_∈∘_./ _)› [0, 0, 10] 10)

translations "⋂∘x∈∘A. f" ⇌ "CONST VInter (CONST imVLambda A (λx. f))"


text‹Rules.›

lemma vifintersectionI[intro]:
  assumes "I ≠ 0" and "⋀i. i ∈∘ I ⟹ a ∈∘ f i"  
  shows "a ∈∘ (⋂∘i∈∘I. f i)"
  using assms by (auto intro!: vsubset_antisym)

lemma vifintersectionD[dest]:
  assumes "a ∈∘ (⋂∘i∈∘I. f i)" and "i ∈∘ I"
  shows "a ∈∘ f i"
  using assms by blast

lemma vifintersectionE1[elim]:
  assumes "a ∈∘ (⋂∘i∈∘I. f i)" and "a ∈∘ f i ⟹ P" and "i ∉∘ I ⟹ P" 
  shows P
  using assms by blast

lemma vifintersectionE3[elim]:
  assumes "a ∈∘ (⋂∘i∈∘I. f i)"
  obtains "⋀i. i∈∘I ⟹ a ∈∘ f i"
  using assms by blast

lemma vifintersectionE2[elim]:
  assumes "a ∈∘ (⋂∘i∈∘I. f i)"
  obtains i where "i ∈∘ I" and "a ∈∘ f i"
  using assms by (elim vifintersectionE3) (meson assms VInterE2 app_vimageE)


text‹Set operations.›

lemma vifintersection_vempty_is[simp]: "(⋂∘i∈∘0. f i) = 0" by auto

lemma vifintersection_vsingleton_is[simp]: "(⋂∘i∈∘set{i}. f i) = f i"
  using elts_0 by blast

lemma vifintersection_vdoubleton_is[simp]: "(⋂∘i∈∘set {i, j}. f i) = f i ∩∘ f j"  
  by 
    (
      intro vsubset_antisym vsubsetI; 
      (elim vifintersectionE3 | intro vifintersectionI)
    )
    auto

lemma vifintersection_antimono1: 
  assumes "I ≠ 0" and "I ⊆∘ J"
  shows "(⋂∘j∈∘J. f j) ⊆∘ (⋂∘i∈∘I. f i)"
  using assms by blast

lemma vifintersection_antimono2: 
  assumes "I ≠ 0" and " I ⊆∘ J" and "⋀i. i ∈∘ I ⟹ f i ⊆∘ g i"
  shows "(⋂∘j∈∘J. f j) ⊆∘ (⋂∘i∈∘I. g i)"
  using assms by blast

lemma vifintersection_vintersection: 
  assumes "I ≠ 0" and "J ≠ 0"
  shows "(⋂∘i∈∘I. f i) ∩∘ (⋂∘i∈∘J. f i) = (⋂∘i∈∘I ∪∘ J. f i)"
  using assms by (auto intro!: vsubset_antisym)

lemma vifintersection_vintersection_family: 
  assumes "I ≠ 0" 
  shows "(⋂∘i∈∘I. A i) ∩∘ (⋂∘i∈∘I. B i) = (⋂∘i∈∘I. A i ∩∘ B i)"
  using assms
  by (intro vsubset_antisym vsubsetI, intro vifintersectionI | tactic‹all_tac›) 
    blast+

lemma vifintersection_vunion:
  assumes "I ≠ 0" and "J ≠ 0"
  shows "(⋂∘i∈∘I. f i) ∪∘ (⋂∘j∈∘J. g j) = (⋂∘i∈∘I. ⋂∘j∈∘J. f i ∪∘ g j)"
  using assms by (blast intro!: vsubset_antisym)

lemma vifintersection_vinsert_is[intro, simp]:
  assumes "I ≠ 0" 
  shows "(⋂∘i ∈∘ vinsert j I. f i) = f j ∩∘ (⋂∘i∈∘I. f i)"
  apply(insert assms, intro vsubset_antisym vsubsetI)
  subgoal for b by (subgoal_tac ‹b ∈∘ f j› ‹b ∈∘ (⋂∘i∈∘I. f i)›) blast+
  subgoal for b 
    by (subgoal_tac ‹b ∈∘ f j› ‹b ∈∘ (⋂∘i∈∘I. f i)›) 
      (blast intro!: vsubset_antisym)+
  done

lemma vifintersection_VPow: 
  assumes "I ≠ 0"
  shows "VPow (⋂∘i∈∘I. f i) = (⋂∘i∈∘I. VPow (f i))"
  using assms by (auto intro!: vsubset_antisym)


text‹Elementary properties.›

lemma vifintersection_constant[intro, simp]:
  assumes "I ≠ 0"
  shows "(⋂∘y∈∘I. c) = c"
  using assms by auto

lemma vifintersection_vsubset_iff: 
  assumes "I ≠ 0"
  shows "A ⊆∘ (⋂∘i∈∘I. f i) ⟷ (∀i∈∘I. A ⊆∘ f i)"
  using assms by blast

lemma vifintersection_vsubset_lower: 
  assumes "i ∈∘ I"
  shows "(⋂∘i∈∘I. f i) ⊆∘ f i"
  using assms by blast

lemma vifintersection_vsubset_greatest: 
  assumes "I ≠ 0" and "⋀i. i ∈∘ I ⟹ A ⊆∘ f i" 
  shows "A ⊆∘ (⋂∘i∈∘I. f i)"
  using assms by (intro vsubsetI vifintersectionI) auto 

lemma vifintersection_vintersection_value: 
  assumes "i ∈∘ I"
  shows "f i ∩∘ (⋂∘i∈∘I. f i) = (⋂∘i∈∘I. f i)"
  using assms by blast

lemma vifintersection_vintersection_single: 
  assumes "I ≠ 0"
  shows "B ∪∘ (⋂∘i∈∘I. A i) = (⋂∘i∈∘I. B ∪∘ A i)"
  by (insert assms, intro vsubset_antisym vsubsetI vifintersectionI) 
    blast+


text‹Connections.›

lemma vifintersection_vrange_VLambda: "(⋂∘i∈∘I. f i) = ⋂∘ (ℛ∘ (λa∈∘I. f a))"
  by (simp add: vimage_VLambda_vrange_rep)



subsection‹Union of an indexed family of sets›

syntax "_VIFUNION" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3⋃∘_∈∘_./ _)› [0, 0, 10] 10)

translations "⋃∘x∈∘A. f" ⇌ "CONST VUnion (CONST imVLambda A (λx. f))"


text‹Rules.›

lemma vifunion_iff: "b ∈∘ (⋃∘i∈∘I. f i) ⟷ (∃i∈∘I. b ∈∘ f i)" by force

lemma vifunionI[intro]: 
  assumes "i ∈∘ I" and "a ∈∘ f i" 
  shows "a ∈∘ (⋃∘i∈∘I. f i)" 
  using assms by force

lemma vifunionD[dest]: 
  assumes "a ∈∘ (⋃∘i∈∘I. f i)" 
  shows "∃i∈∘I. a ∈∘ f i" 
  using assms by auto

lemma vifunionE[elim!]: 
  assumes "a ∈∘ (⋃∘i∈∘I. f i)" and "⋀i. ⟦ i ∈∘ I; a ∈∘ f i ⟧ ⟹ R" 
  shows R
  using assms by auto


text‹Set operations.›

lemma vifunion_vempty_family[simp]: "(⋃∘i∈∘I. 0) = 0" by auto

lemma vifunion_vsingleton_is[simp]: "(⋃∘i∈∘set {i}. f i) = f i" by force

lemma vifunion_vsingleton_family[simp]: "(⋃∘i∈∘I. set {i}) = I" by force

lemma vifunion_vdoubleton: "(⋃∘i∈∘set {i, j}. f i) = f i ∪∘ f j" 
  using VLambda_vinsert vimage_vunion_left
  by (force simp: VLambda_vsingleton simp: vinsert_set_insert_eq)

lemma vifunion_mono:
  assumes "I ⊆∘ J" and "⋀i. i ∈∘ I ⟹ f i ⊆∘ g i" 
  shows "(⋃∘i∈∘I. f i) ⊆∘ (⋃∘j∈∘J. g j)"
  using assms by force

lemma vifunion_vunion_is: "(⋃∘i∈∘I. f i) ∪∘ (⋃∘j∈∘J. f j) = (⋃∘i∈∘I ∪∘ J. f i)"
  by force

lemma vifunion_vunion_family:
  "(⋃∘i∈∘I. f i) ∪∘ (⋃∘i∈∘I. g i) = (⋃∘i∈∘I. f i ∪∘ g i)"  
  by (intro vsubset_antisym vsubsetI; elim vunionE vifunionE) force+

lemma vifunion_vintersection: 
  "(⋃∘i∈∘I. f i) ∩∘ (⋃∘j∈∘J. g j) = (⋃∘i∈∘I. ⋃∘j∈∘J. f i ∩∘ g j)"
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vinsert_is: 
  "(⋃∘i∈∘vinsert j I. f i) = f j ∪∘ (⋃∘i∈∘I. f i)"
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_VPow: "(⋃∘i∈∘I. VPow (f i)) ⊆∘ VPow (⋃∘i∈∘I. f i)" by force


text‹Elementary properties.›

lemma vifunion_vempty_conv:
  "0 = (⋃∘i∈∘I. f i) ⟷ (∀i∈∘I. f i = 0)"
  "(⋃∘i∈∘I. f i) = 0 ⟷ (∀i∈∘I. f i = 0)"
  by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_constant[simp]: "(⋃∘i∈∘I. c) = (if I = 0 then 0 else c)" 
proof(intro vsubset_antisym)
  show "(if I = 0 then 0 else c) ⊆∘ (⋃∘i∈∘I. c)"
    by (cases ‹vdisjnt I I›) (auto simp: VLambda_vconst_on)
qed auto

lemma vifunion_upper:
  assumes "i ∈∘ I"
  shows "f i ⊆∘ (⋃∘i∈∘I. f i)"
  using assms by force

lemma vifunion_least: 
  assumes "⋀i. i ∈∘ I ⟹ f i ⊆∘ C"
  shows "(⋃∘i∈∘I. f i) ⊆∘ C"
  using assms by auto

lemma vifunion_absorb: 
  assumes "j ∈∘ I"
  shows "f j ∪∘ (⋃∘i∈∘I. f i) = (⋃∘i∈∘I. f i)" 
  using assms by force

lemma vifunion_vifunion_flatten: 
  "(⋃∘j∈∘(⋃∘i∈∘I. f i). g j) = (⋃∘i∈∘I. ⋃∘j∈∘f i. g j)"
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vsubset_iff: "((⋃∘i∈∘I. f i) ⊆∘ B) = (∀i∈∘I. f i ⊆∘ B)" by force

lemma vifunion_vsingleton_eq_vrange: "(⋃∘i∈∘I. set {f i}) = ℛ∘ (λa∈∘I. f a)"
  by force

lemma vball_vifunion[simp]: "(∀z∈∘(⋃∘i∈∘I. f i). P z) ⟷ (∀x∈∘I. ∀z∈∘f x. P z)"
  by force

lemma vbex_vifunion[simp]: "(∃z∈∘(⋃∘i∈∘I. f i). P z) ⟷ (∃x∈∘I. ∃z∈∘f x. P z)"
  by force

lemma vifunion_vintersection_index_right[simp]: "(⋃∘C∈∘B. A ∩∘ C) = A ∩∘ ⋃∘B" 
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_vintersection_index_left[simp]: "(⋃∘C∈∘B. C ∩∘ A) = ⋃∘B ∩∘ A" 
  by (force simp: vimage_VLambda_vrange_rep)

lemma vifunion_vunion_index[intro, simp]:
  assumes "B ≠ 0"
  shows "(⋂∘C∈∘B. A ∪∘ C) = A ∪∘ ⋂∘B"
  using assms
  by 
    (
      (intro vsubset_antisym vsubsetI); 
      (intro vifintersectionI | tactic‹all_tac›)
    ) 
    blast+

lemma vifunion_vintersection_single: "B ∩∘ (⋃∘i∈∘I. f i) = (⋃∘i∈∘I. B ∩∘ f i)" 
  by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vifunion_vifunion_flip: 
  "(⋃∘b∈∘B. ⋃∘a∈∘A. f b a) = (⋃∘a∈∘A. ⋃∘b∈∘B. f b a)"
proof-
  have "x ∈∘ (⋃∘a∈∘A. ⋃∘b∈∘B. f b a)" if "x ∈∘ (⋃∘b∈∘B. ⋃∘a∈∘A. f b a)" 
    for x f A B 
  proof-
    from that obtain b where b: "b ∈∘ B" and x_b: "x ∈∘ (⋃∘a∈∘A. f b a)" 
      by fastforce
    then obtain a where a: "a ∈∘ A" and x_fba: "x ∈∘ f b a" by fastforce
    show "x ∈∘ (⋃∘a∈∘A. ⋃∘b∈∘B. f b a)"
      unfolding vifunion_iff by (auto intro: a b x_fba)
  qed
  then show ?thesis by (intro vsubset_antisym vsubsetI) auto
qed


text‹Connections.›

lemma vifunion_disjoint: "(⋃∘C ∩∘ A = 0) ⟷ (∀B∈∘C. vdisjnt B A)" 
  by (intro iffI)
    (auto intro!: vsubset_antisym simp: Sup_upper vdisjnt_vsubset_left)

lemma vdisjnt_vifunion_iff: 
  "vdisjnt A (⋃∘i∈∘I. f i) ⟷ (∀i∈∘I. vdisjnt A (f i))"
  by (force intro!: vsubset_antisym simp: vdisjnt_iff)+

lemma vifunion_VLambda: "(⋃∘i∈∘A. set {⟨i, f i⟩}) = (λa∈∘A. f a)" 
  using vifunionI by (intro vsubset_antisym vsubsetI) auto

lemma vifunion_vrange_VLambda: "(⋃∘i∈∘I. f i) = ⋃∘(ℛ∘ (λa∈∘I. f a))"
  using vimage_VLambda_vrange_rep by auto

lemma (in vsv) vsv_vrange_vsubset_vifunion_app:
  assumes "𝒟∘ r = I" and "⋀i. i ∈∘ I ⟹ r⦇i⦈ ∈∘ A i" 
  shows "ℛ∘ r ⊆∘ (⋃∘i∈∘I. A i)"
proof(intro vsubsetI)
  fix x assume "x ∈∘ ℛ∘ r"
  with assms(1) obtain i where x_def: "x = r⦇i⦈" and i: "i ∈∘ I"
    by (metis vrange_atE)
  from i assms(2)[rule_format, OF i] show "x ∈∘ (⋃∘i∈∘I. A i)"
    unfolding x_def by (intro vifunionI) auto
qed

lemma v11_vlrestriction_vifintersection: 
  assumes "I ≠ 0" and "⋀i. i ∈∘ I ⟹ v11 (f ↾l∘ (A i))" 
  shows "v11 (f ↾l∘ (⋂∘i∈∘I. A i))"
proof(intro v11I)
  show "vsv (f ↾l∘ ⋂∘ ((λa∈∘I. A a) `∘ I))"
    (*slow*)
    apply(subgoal_tac ‹⋀i. i ∈∘ I ⟹ vsv (f ↾l∘ (A i))›)
    subgoal by (insert assms(1), intro vsvI) (blast intro!: vsubset_antisym)+
    subgoal using assms by blast
    done
  show "vsv ((f ↾l∘ ⋂∘ ((λa∈∘I. A a) `∘ I))¯∘)"
  proof(intro vsvI) 
    fix a b c
    assume ab: "⟨a, b⟩ ∈∘ (f ↾l∘ ⋂∘ ((λa∈∘I. A a) `∘ I))¯∘"
      and ac: "⟨a, c⟩ ∈∘ (f ↾l∘ ⋂∘ ((λa∈∘I. A a) `∘ I))¯∘"
    from assms(2) have hyp: "⋀i. i ∈∘ I ⟹ vsv ((f ↾l∘ (A i))¯∘)" by blast
    from assms(1) obtain i where "i ∈∘ I" and "⋂∘ ((λa∈∘I. A a) `∘ I) ⊆∘ A i"
      by (auto intro!: vsubset_antisym)
    with ab ac hyp ‹i ∈∘ I› show "b = c" by auto
  qed auto
qed



subsection‹Additional simplification rules for indexed families of sets.›


text‹Union.›

lemma vifunion_simps[simp]:
  "⋀a B I. (⋃∘i∈∘I. vinsert a (B i)) = 
    (if I=0 then 0 else vinsert a (⋃∘i∈∘I. B i))"
  "⋀A B I. (⋃∘i∈∘I. A i ∪∘ B) = ((if I=0 then 0 else (⋃∘i∈∘I. A i) ∪∘ B))"
  "⋀A B I. (⋃∘i∈∘I. A ∪∘ B i) = ((if I=0 then 0 else A ∪∘ (⋃∘i∈∘I. B i)))"
  "⋀A B I. (⋃∘i∈∘I. A i ∩∘ B) = ((⋃∘i∈∘I. A i) ∩∘ B)"
  "⋀A B I. (⋃∘i∈∘I. A ∩∘ B i) = (A ∩∘ (⋃∘i∈∘I. B i))"
  "⋀A B I. (⋃∘i∈∘I. A i -∘ B) = ((⋃∘i∈∘I. A i) -∘ B)"
  "⋀A B. (⋃∘i∈∘⋃∘A. B i) = (⋃∘y∈∘A. ⋃∘i∈∘y. B i)"
  by 
    (
      force 
        simp: vrange_VLambda vimage_VLambda_vrange_rep
        intro!: vsubset_antisym
    )+

lemma vifunion_simps_ext:
  "⋀a B I. vinsert a (⋃∘i∈∘I. B i) = 
    (if I=0 then set {a} else (⋃∘i∈∘I. vinsert a (B i)))"
  "⋀A B I. (⋃∘i∈∘I. A i) ∪∘ B = (if I=0 then B else (⋃∘i∈∘I. A i ∪∘ B))"
  "⋀A B I. A ∪∘ (⋃∘i∈∘I. B i) = (if I=0 then A else (⋃∘i∈∘I. A ∪∘ B i))"
  "⋀A B I. ((⋃∘i∈∘I. A i) ∩∘ B) = (⋃∘i∈∘I. A i ∩∘ B)"
  "⋀A B I. ((⋃∘i∈∘I. A i) -∘ B) = (⋃∘i∈∘I. A i -∘ B)"
  "⋀A B. (⋃∘y∈∘A. ⋃∘i∈∘y. B i) = (⋃∘i∈∘⋃∘A. B i)"
  by (auto simp: vrange_VLambda)

lemma vifunion_vball_vbex_simps[simp]:
  "⋀A P. (∀a∈∘⋃∘A. P a) ⟷ (∀y∈∘A. ∀a∈∘y. P a)"
  "⋀A P. (∃a∈∘⋃∘A. P a) ⟷ (∃y∈∘A. ∃a∈∘y. P a)"
  using vball_vifunion vbex_vifunion by auto


text‹Intersection.›

lemma vifintersection_simps[simp]: 
  "⋀I A B. (⋂∘i∈∘I. A i ∩∘ B) = (if I = 0 then 0 else (⋂∘i∈∘I. A i) ∩∘ B)"
  "⋀I A B. (⋂∘i∈∘I. A ∩∘ B i) = (if I = 0 then 0 else A ∩∘ (⋂∘i∈∘I. B i))"
  "⋀I A B. (⋂∘i∈∘I. A i -∘ B) = (if I = 0 then 0 else (⋂∘i∈∘I. A i) -∘ B)"
  "⋀I A B. (⋂∘i∈∘I. A -∘ B i) = (if I = 0 then 0 else A -∘ (⋃∘i∈∘I. B i))"
  "⋀I a B. 
    (⋂∘i∈∘I. vinsert a (B i)) = (if I = 0 then 0 else vinsert a (⋂∘i∈∘I. B i))"
  "⋀I A B. (⋂∘i∈∘I. A i ∪∘ B) = (if I = 0 then 0 else ((⋂∘i∈∘I. A i) ∪∘ B))"
  "⋀I A B. (⋂∘i∈∘I. A ∪∘ B i) = (if I = 0 then 0 else (A ∪∘ (⋂∘i∈∘I. B i)))"
  by force+

lemma vifintersection_simps_ext:
  "⋀A B I. (⋂∘i∈∘I. A i) ∩∘ B = (if I = 0 then 0 else (⋂∘i∈∘I. A i ∩∘ B))"
  "⋀A B I. A ∩∘ (⋂∘i∈∘I. B i) = (if I = 0 then 0 else (⋂∘i∈∘I. A ∩∘ B i))"
  "⋀A B I. (⋂∘i∈∘I. A i) -∘ B = (if I = 0 then 0 else (⋂∘i∈∘I. A i -∘ B))"
  "⋀A B I. A -∘ (⋃∘i∈∘I. B i) = (if I = 0 then A else (⋂∘i∈∘I. A -∘ B i))"
  "⋀a B I. vinsert a (⋂∘i∈∘I. B i) = 
    (if I = 0 then set {a} else (⋂∘i∈∘I. vinsert a (B i)))"
  "⋀A B I. ((⋂∘i∈∘I. A i) ∪∘ B) = (if I = 0 then B else (⋂∘i∈∘I. A i ∪∘ B))"
  "⋀A B I. A ∪∘ (⋂∘i∈∘I. B i) = (if I = 0 then A else (⋂∘i∈∘I. A ∪∘ B i))"
  using vifintersection_simps by auto



subsection‹Knowledge transfer: union and intersection of indexed families›

lemma SUP_vifunion: "(SUP ξ∈elts α. A ξ) = (⋃∘ξ∈∘α. A ξ)"
  by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)

lemma INF_vifintersection: "(INF ξ∈elts α. A ξ) = (⋂∘ξ∈∘α. A ξ)"
  by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)

lemmas Ord_induct3'[consumes 1, case_names 0 succ Limit, induct type: V] =
  Ord_induct3[unfolded SUP_vifunion]

lemma Limit_vifunion_def[simp]:
  assumes "Limit α"
  shows "(⋃∘ξ∈∘α. ξ) = α"
  using assms unfolding SUP_vifunion[symmetric] by simp

lemmas_with[unfolded SUP_vifunion INF_vifintersection]: 
  TC = ZFC_Cardinals.TC
  and rank_Sup = ZFC_Cardinals.rank_Sup
  and TC_def = ZFC_Cardinals.TC_def
  and Ord_equality = ZFC_in_HOL.Ord_equality
  and Aleph_Limit = ZFC_Cardinals.Aleph_Limit
  and rank = ZFC_Cardinals.rank
  and Vset = ZFC_in_HOL.Vset
  and mult = Kirby.mult
  and Aleph_def = ZFC_Cardinals.Aleph_def
  and times_V_def = Kirby.times_V_def
  and mult_Limit = Kirby.mult_Limit
  and Vfrom = ZFC_in_HOL.Vfrom
  and Vfrom_def = ZFC_in_HOL.Vfrom_def
  and rank_def = ZFC_Cardinals.rank_def
  and add_Limit = Kirby.add_Limit
  and Limit_Vfrom_eq = ZFC_in_HOL.Limit_Vfrom_eq
  and VSigma_def = ZFC_Cardinals.VSigma_def
  and add_Sup_distrib_id = Kirby.add_Sup_distrib_id
  and Limit_add_Sup_distrib = Kirby.Limit_add_Sup_distrib
  and TC_mult = Kirby.TC_mult
  and add_Sup_distrib = Kirby.add_Sup_distrib



subsection‹Disjoint union›


text‹
Fundamental properties have already been exposed in the main library
of ‹ZFC in HOL›.
›

syntax "_VPRODUCT" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3∐×_∈∘_./ _)› [0, 0, 10] 10)

translations "∐×i∈∘I. A" ⇌ "CONST VSigma I (λi. A)"


text‹Further rules.›

lemma vdunion_expE[elim!]:
  assumes "c ∈∘ (⋃∘i∈∘I. ⋃∘x∈∘A i. set {⟨i, x⟩})"
  obtains i a where "i ∈∘ I" and "a ∈∘ A i" and "c = ⟨i, a⟩"
  using assms by (clarsimp simp: vrange_VLambda vimage_VLambda_vrange_rep)

lemma vdunion_def: "(∐×i∈∘I. A i) = (⋃∘i∈∘I. ⋃∘x∈∘A i. set {⟨i, x⟩})" 
  by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)


text‹Set operations.›

lemma vdunion_vsingleton: "(∐×i∈∘set{c}. A i) = set {c} ×∘ A c" by auto

lemma vdunion_vdoubleton: 
  "(∐×i∈∘set{a, b}. A i) = set {a} ×∘ A a ∪∘ set {b} ×∘ A b" 
  by auto


text‹Connections.›

lemma vdunion_vsum: "(∐×i∈∘set{0, 1}. if i=0 then A else B) = A ⨄ B"
  unfolding vdunion_vdoubleton vsum_def by simp



subsection‹Infinite Cartesian product›

definition vproduct :: "V ⇒ (V ⇒ V) ⇒ V"
  where "vproduct I A = set {f. vsv f ∧ 𝒟∘ f = I ∧ (∀i∈∘I. f⦇i⦈ ∈∘ A i)}"

syntax "_VPRODUCT" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3∏∘_∈∘_./ _)› [0, 0, 10] 10)

translations "∏∘i∈∘I. A" ⇌ "CONST vproduct I (λi. A)"

lemma small_vproduct[simp]:
  "small {f. vsv f ∧ 𝒟∘ f = I ∧ (∀i∈∘I. f⦇i⦈ ∈∘ A i)}"
  (is ‹small ?A›)
proof-
  from small_vsv[of I ‹(⋃∘i∈∘I. A i)›] have 
    "small {f. vsv f ∧ 𝒟∘ f = I ∧ ℛ∘ f ⊆∘ (⋃∘i∈∘I. A i)}"
    by simp
  moreover have "?A ⊆ {f. vsv f ∧ 𝒟∘ f = I ∧ ℛ∘ f ⊆∘ (⋃∘i∈∘I. A i)}"
  proof(intro subsetI, unfold mem_Collect_eq, elim conjE, intro conjI)
    fix f assume prems: "vsv f" "𝒟∘ f = I" "∀i∈elts I. f⦇i⦈ ∈∘ A i"
    interpret vsv f by (rule prems(1))
    show "ℛ∘ f ⊆∘ (⋃∘i∈∘I. A i)"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ f"
      with prems(2) obtain i where y_def: "y = f⦇i⦈" and i: "i ∈∘ I"
        by (blast dest: vrange_atD)
      from i prems(3) vifunionI show "y ∈∘ (⋃∘i∈∘I. A i)" 
        unfolding y_def by auto
    qed
  qed
  ultimately show ?thesis by (metis (lifting) smaller_than_small)
qed


text‹Rules.›

lemma vproductI[intro!]:
  assumes "vsv f" and "𝒟∘ f = I" and "∀i∈∘I. f⦇i⦈ ∈∘ A i"
  shows "f ∈∘ (∏∘i∈∘I. A i)"
  using assms small_vproduct unfolding vproduct_def by auto

lemma vproductD[dest]:
  assumes "f ∈∘ (∏∘i∈∘I. A i)"
  shows "vsv f" 
    and "𝒟∘ f = I"
    and "∀i∈∘I. f⦇i⦈ ∈∘ A i"
  using assms unfolding vproduct_def by auto

lemma vproductE[elim!]:
  assumes "f ∈∘ (∏∘i∈∘I. A i)"
  obtains "vsv f" and "𝒟∘ f = I" and "∀i∈∘I. f⦇i⦈ ∈∘ A i"
  using assms unfolding vproduct_def by auto


text‹Set operations.›

lemma vproduct_index_vempty[simp]: "(∏∘i∈∘0. A i) = set {0}"
proof-
  have "{f. vsv f ∧ 𝒟∘ f = 0 ∧ (∀i∈∘0. f⦇i⦈ ∈∘ A i)} = {0}"
    using vbrelation.vlrestriction_vdomain vsv_eqI by fastforce
  then show ?thesis unfolding vproduct_def by simp
qed

lemma vproduct_vsingletonI:
  assumes "f⦇c⦈ ∈∘ A c" and "f = set {⟨c, f⦇c⦈⟩}" 
  shows "f ∈∘ (∏∘i∈∘set{c}. A i)"
  using assms 
  apply(intro vproductI)
  subgoal by (metis rel_vsingleton.vsv_axioms)
  subgoal by (force intro!: vsubset_antisym)
  subgoal by auto
  done

lemma vproduct_vsingletonD: 
  assumes "f ∈∘ (∏∘i∈∘set{c}. A i)" 
  shows "vsv f" and "f⦇c⦈ ∈∘ A c" and "f = set {⟨c, f⦇c⦈⟩}"
proof-
  from assms show "f = set {⟨c, f⦇c⦈⟩}"
    by (elim vproductE) (metis VLambda_vsingleton  vsv.vsv_is_VLambda)
qed (use assms in auto)

lemma vproduct_vsingletonE: 
  assumes "f ∈∘ (∏∘i∈∘set{c}. A i)" 
  obtains "vsv f" and "f⦇c⦈ ∈∘ A c" and "f = set {⟨c, f⦇c⦈⟩}"
  using assms vproduct_vsingletonD that by auto

lemma vproduct_vsingleton_iff: 
  "f ∈∘ (∏∘i∈∘set{c}. A i) ⟷ f⦇c⦈ ∈∘ A c ∧ f = set {⟨c, f⦇c⦈⟩}" 
  by (rule iffI) (auto simp: vproduct_vsingletonD intro!: vproduct_vsingletonI)

lemma vproduct_vdoubletonI[intro]:
  assumes "vsv f"
    and "f⦇a⦈ ∈∘ A a" 
    and "f⦇b⦈ ∈∘ A b" 
    and "𝒟∘ f = set {a, b}"
    and "ℛ∘ f ⊆∘ A a ∪∘ A b"
  shows "f ∈∘ (∏∘i∈∘set {a, b}. A i)"
  using assms vifunion_vdoubleton by (intro vproductI) auto

lemma vproduct_vdoubletonD[dest]: 
  assumes "f ∈∘ (∏∘i∈∘set{a, b}. A i)" 
  shows "vsv f"
    and "f⦇a⦈ ∈∘ A a" 
    and "f⦇b⦈ ∈∘ A b" 
    and "𝒟∘ f = set {a, b}" 
    and "f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}"
  subgoal using assms by auto
  subgoal using assms by auto
  subgoal using assms by auto
  subgoal using assms vifunion_vdoubleton by fastforce
  subgoal by (metis assms VLambda_vdoubleton vproductE vsv.vsv_is_VLambda)
  done

lemma vproduct_vdoubletonE: 
  assumes "f ∈∘ (∏∘i∈∘set{a, b}. A i)" 
  obtains "vsv f"
    and "f⦇a⦈ ∈∘ A a" 
    and "f⦇b⦈ ∈∘ A b" 
    and "𝒟∘ f = set {a, b}" 
    and "f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}"
  using assms vproduct_vdoubletonD that by simp

lemma vproduct_vdoubleton_iff: 
  "f ∈∘ (∏∘i∈∘set {a, b}. A i) ⟷ 
    vsv f ∧ 
    f⦇a⦈ ∈∘ A a ∧ 
    f⦇b⦈ ∈∘ A b ∧ 
    𝒟∘ f = set {a, b} ∧ 
    f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}" 
  by (force elim!: vproduct_vdoubletonE)+


text‹Elementary properties.›

lemma vproduct_eq_vemptyI:
  assumes "i ∈∘ I" and "A i = 0"
  shows "(∏∘i∈∘I. A i) = 0"
proof(intro vsubset_antisym vsubsetI)
  fix x assume prems: "x ∈∘ (∏∘i∈∘I. A i)"
  from assms vproductD(3)[OF prems] show "x ∈∘ 0" by auto
qed auto

lemma vproduct_eq_vemptyD:
  assumes "(∏∘i∈∘I. A i) ≠ 0"
  shows "⋀i. i ∈∘ I ⟹ A i ≠ 0"
proof(rule ccontr, unfold not_not)
  fix i assume prems: "i ∈∘ I" "A i = 0"
  with vproduct_eq_vemptyI[where A=A, OF prems] assms show False by simp
qed

lemma vproduct_vrange:
  assumes "f ∈∘ (∏∘i∈∘I. A i)"
  shows "ℛ∘ f ⊆∘ (⋃∘i∈∘I. A i)"
proof(intro vsubsetI)
  fix x assume prems: "x ∈∘ ℛ∘ f"
  have vsv_f: "vsv f"
    and dom_f: "𝒟∘ f = I"
    and fi: "⋀i. i ∈∘ I ⟹ f⦇i⦈ ∈∘ A i"
    by (simp_all add: vproductD[OF assms, rule_format])
  interpret f: vsv f by (rule vsv_f)
  from prems dom_f obtain i where x_def: "x = f⦇i⦈" and i: "i ∈∘ I"
    by (auto elim: f.vrange_atE) 
  from i fi show "x ∈∘ (⋃∘i∈∘I. A i)" unfolding x_def by (intro vifunionI) auto
qed

lemma vproduct_vsubset_VPow: "(∏∘i∈∘I. A i) ⊆∘ VPow (I ×∘ (⋃∘i∈∘I. A i))"
proof(intro vsubsetI)
  fix f assume "f ∈∘ (∏∘i∈∘I. A i)"
  then have vsv: "vsv f" 
    and domain: "𝒟∘ f = I" 
    and range: "∀i∈elts I. f⦇i⦈ ∈∘ A i" 
    by auto
  interpret f: vsv f by (rule vsv)
  have "f ⊆∘ I ×∘ (⋃∘i∈∘I. A i)"
  proof(intro vsubsetI)
    fix x assume prems: "x ∈∘ f"
    then obtain a b where x_def: "x = ⟨a, b⟩" by (elim f.vbrelation_vinE)
    with prems have "a ∈∘ 𝒟∘ f" and "b ∈∘ ℛ∘ f" by auto
    with range domain prems show "x ∈∘ I ×∘ (⋃∘i∈∘I. A i)"
      by (fastforce simp: x_def)
  qed
  then show "f ∈∘ VPow (I ×∘ (⋃∘i∈∘I. A i))" by simp
qed

lemma VLambda_in_vproduct:
  assumes "⋀i. i ∈∘ I ⟹ f i ∈∘ A i"
  shows "(λi∈∘I. f i) ∈∘ (∏∘i∈∘I. A i)"
  using assms by (simp add: vproductI vsv.vsv_vrange_vsubset_vifunion_app)

lemma vproduct_cong:
  assumes "⋀i. i ∈∘ I ⟹ f i = g i"
  shows "(∏∘i∈∘I. f i) = (∏∘i∈∘I. g i)"
proof-
  have "(∏∘i∈∘I. f i) ⊆∘ (∏∘i∈∘I. g i)" if "⋀i. i ∈∘ I ⟹ f i = g i" for f g
  proof(intro vsubsetI)
    fix x assume "x ∈∘ (∏∘i∈∘I. f i)"
    note xD = vproductD[OF this]     
    interpret vsv x by (rule xD(1))
    show "x ∈∘ (∏∘i∈∘I. g i)" 
      by (metis xD(2,3) that VLambda_in_vproduct vsv_is_VLambda)
  qed
  with assms show ?thesis by (intro vsubset_antisym) auto
qed

lemma vproduct_ex_in_vproduct:
  assumes "x ∈∘ (∏∘i∈∘J. A i)" and "J ⊆∘ I" and "⋀i. i ∈∘ I ⟹ A i ≠ 0"
  obtains X where "X ∈∘ (∏∘i∈∘I. A i)" and "x = X ↾l∘ J"
proof-
  define X where "X = (λi∈∘I. if i ∈∘ J then x⦇i⦈ else (SOME x. x ∈∘ A i))" 
  have X: "X ∈∘ (∏∘i∈∘I. A i)"
    by (intro vproductI) (use assms in ‹auto simp: X_def›)
  moreover have "x = X ↾l∘ J"
  proof(rule vsv_eqI)
    from assms(1) have [simp]: "𝒟∘ x = J" by clarsimp 
    moreover from assms(2) have "𝒟∘ (X ↾l∘ J) = J" unfolding X_def by fastforce
    ultimately show "𝒟∘ x = 𝒟∘ (X ↾l∘ J)" by simp 
    show "x⦇i⦈ = (X ↾l∘ J)⦇i⦈" if "i ∈∘ 𝒟∘ x" for i
      using that assms(2) unfolding X_def by auto
  qed (use assms X in auto)
  ultimately show ?thesis using that by simp
qed

lemma vproduct_vsingleton_def: "(∏∘i∈∘set {j}. A i) = (∏∘i∈∘set {j}. A j)"
  by auto

lemma vprojection_in_VUnionI:
  assumes "A ⊆∘ (∏∘i∈∘I. F i)" and "f ∈∘ A" and "i ∈∘ I"
  shows "f⦇i⦈ ∈∘ ⋃∘(⋃∘(⋃∘A))"
proof(intro VUnionI)
  show "f ∈∘ A" by (rule assms(2))
  from assms(1,2) have "f ∈∘ (∏∘i∈∘I. F i)" by auto
  note f = vproductD[OF this, rule_format]
  interpret vsv f rewrites "𝒟∘ f = I" by (auto intro: f(1) simp: f(2))
  show "⟨i, f⦇i⦈⟩ ∈∘ f" by (meson assms(3) vsv_appE)
  show "set {i, f⦇i⦈} ∈∘ ⟨i, f⦇i⦈⟩" unfolding vpair_def by simp
qed simp


subsection‹Projection›

definition vprojection :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V"
  where "vprojection I A i = (λf∈∘(∏∘i∈∘I. A i). f⦇i⦈)"


text‹Rules.›

mk_VLambda vprojection_def
  |vsv vprojection_vsv[intro]|
  |vdomain vprojection_vdomain[simp]|
  |app vprojection_app[simp, intro]|


text‹Elementary results.›

lemma vprojection_vrange_vsubset: 
  assumes "i ∈∘ I" 
  shows "ℛ∘ (vprojection I A i) ⊆∘ A i"
  unfolding vprojection_def
proof(intro vrange_VLambda_vsubset)
  fix f assume prems: "f ∈∘ (∏∘i∈∘I. A i)"
  show "f⦇i⦈ ∈∘ A i" by (intro vproductD(3)[OF prems, rule_format] assms)
qed

lemma vprojection_vrange: 
  assumes "i ∈∘ I" and "⋀j. j ∈∘ I ⟹ A j ≠ 0"
  shows "ℛ∘ (vprojection I A i) = A i"
proof
  (
    intro 
      vsubset_antisym vprojection_vrange_vsubset vrange_VLambda_vsubset assms(1)
  )
  show "A i ⊆∘ ℛ∘ (vprojection I A i)"
  proof(intro vsubsetI)
    fix x assume prems: "x ∈∘ A i"
    obtain f 
      where f: "⋀x. x ∈∘ set {A i | i. i ∈∘ I} ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈∘ x" 
        and "vsv f"
      using that by (rule Axiom_of_Choice)
    define f' where "f' = (λj∈∘I. if j = i then x else f⦇A j⦈)"
    show "x ∈∘ ℛ∘ (vprojection I A i)"               
      unfolding vprojection_def
    proof(rule rel_VLambda.vsv_vimageI2')
      show "f' ∈∘ 𝒟∘ (λf∈∘vproduct I A. f⦇i⦈)"
        unfolding vdomain_VLambda
      proof(intro vproductI, unfold Ball_def; (intro allI conjI impI)?)
        fix j assume "j ∈∘ I"
        with prems assms(2) show "f'⦇j⦈ ∈∘ A j"
          unfolding f'_def by (cases ‹j = i›) (auto intro!: f)
      qed (simp_all add: f'_def)
      with assms(1) show "x = (λf∈∘vproduct I A. f⦇i⦈)⦇f'⦈"
        unfolding f'_def by simp
    qed
  qed
qed



subsection‹Cartesian power of a set›

definition vcpower :: "V ⇒ V ⇒ V" (infixr ‹^×› 80)
  where "A ^× n = (∏∘i∈∘n. A)"


text‹Rules.›

lemma vcpowerI[intro]:
  assumes "f ∈∘ (∏∘i∈∘n. A)"
  shows "f ∈∘ (A ^× n)" 
  using assms unfolding vcpower_def by auto

lemma vcpowerD[dest]:
  assumes "f ∈∘ (A ^× n)"
  shows "f ∈∘ (∏∘i∈∘n. A)"
  using assms unfolding vcpower_def by auto

lemma vcpowerE[elim]:
  assumes "f ∈∘ (A ^× n)" and "f ∈∘ (∏∘i∈∘n. A) ⟹ P"
  shows P
  using assms unfolding vcpower_def by auto


text‹Set operations.›

lemma vcpower_index_vempty[simp]: "A ^× 0 = set {0}"
  unfolding vcpower_def by (rule vproduct_index_vempty)

lemma vcpower_of_vempty: 
  assumes "n ≠ 0"
  shows "0 ^× n = 0"
  using assms unfolding vcpower_def vproduct_def by simp


text‹Connections.›

lemma vcpower_vdomain: 
  assumes "f ∈∘ (A ^× n)"
  shows "𝒟∘ f = n"
  using assms by auto

lemma vcpower_vrange:
  assumes "f ∈∘ (A ^× n)"
  shows "ℛ∘ f ⊆∘ A"
  using assms by (intro vsubsetI; elim vcpowerE vproductE) auto

text‹\newpage›

end

Theory CZH_Sets_Equipollence

(* Copyright 2021 (C) Mihails Milehins *)

section‹Equipollence›
theory CZH_Sets_Equipollence
  imports CZH_Sets_IF
begin



subsection‹Background›


text‹
The section presents an adaption of the existing framework ‹Equipollence›
in the main library of Isabelle/HOL to the type typ‹V›.

Some of content of this theory was ported directly (with amendments) from the 
theory ‹HOL-Library.Equipollence› in the main library of Isabelle/HOL.
›



subsection‹‹veqpoll››

abbreviation veqpoll :: "V ⇒ V ⇒ bool" (infixl "≈∘" 50) 
  where "A ≈∘ B ≡ elts A ≈ elts B"


text‹Rules›

lemma (in v11) v11_veqpollI[intro]:
  assumes "𝒟∘ r = A" and "ℛ∘ r = B"
  shows "A ≈∘ B" 
  unfolding eqpoll_def 
proof(intro exI[of _ ‹λx. r⦇x⦈›] bij_betw_imageI)
  from v11.v11_injective v11_axioms show "inj_on (app r) (elts A)"
    unfolding assms[symmetric] by (intro inj_onI) blast
  show "app r ` elts A = elts B" unfolding assms[symmetric] by force+
qed

lemmas v11_veqpollI[intro] = v11.v11_veqpollI

lemma v11_veqpollE[elim]: 
  assumes "A ≈∘ B" 
  obtains f where "v11 f" and "𝒟∘ f = A" and "ℛ∘ f = B"
proof-
  from assms obtain f where bij_f: "bij_betw f (elts A) (elts B)"
    unfolding eqpoll_def by auto
  then have "v11 (λa∈∘A. f a)" 
    and "𝒟∘ (λa∈∘A. f a) = A" 
    and "ℛ∘ (λa∈∘A. f a) = B"
    by (auto simp add: in_mono vrange_VLambda)
  then show ?thesis using that by simp
qed

  
text‹Set operations.›

lemma veqpoll_vsingleton: "set {x} ≈∘ set {y}"
  by (simp add: singleton_eqpoll)

lemma veqpoll_vinsert:
  assumes "A ≈∘ B" and "a ∉∘ A" and "b ∉∘ B"
  shows "vinsert a A ≈∘ vinsert b B"
  using assms by (simp add: insert_eqpoll_insert_iff)

lemma veqpoll_pair: 
  assumes "a ≠ b" and "c ≠ d"
  shows "set {a, b} ≈∘ set {c, d}"
  using assms by (simp add: insert_eqpoll_cong)

lemma veqpoll_vpair: 
  assumes "a ≠ b" and "c ≠ d"
  shows "⟨a, b⟩ ≈∘ ⟨c, d⟩"
  using assms 
  unfolding vpair_def 
  by (metis doubleton_eq_iff insert_absorb2 veqpoll_pair)



subsection‹‹vlepoll››

abbreviation vlepoll :: "V ⇒ V ⇒ bool" (infixl "≲∘" 50) 
  where "A ≲∘ B ≡ elts A ≲ elts B"


text‹Set operations.›

lemma vlepoll_vsubset: 
  assumes "A ⊆∘ B"
  shows "A ≲∘ B"
  using assms by (simp add: less_eq_V_def subset_imp_lepoll)


text‹Special properties.›

lemma vlepoll_singleton_vinsert: "set {x} ≲∘ vinsert y A" 
  by (simp add: singleton_lepoll)

lemma vlepoll_vempty_iff[simp]: "A ≲∘ 0 ⟷ A = 0" by (rule iffI) fastforce+



subsection‹‹vlespoll››

abbreviation vlesspoll :: "V ⇒ V ⇒ bool" (infixl ‹≺∘› 50)
  where "A ≺∘ B ≡ elts A ≺ elts B"

lemma vlesspoll_def: "A ≺∘ B = (A ≲∘ B ∧ ~(A ≈∘ B))" by (simp add: lesspoll_def)


text‹Rules.›

lemmas vlesspollI[intro] = vlesspoll_def[THEN iffD2]

lemmas vlesspollD[dest] = vlesspoll_def[THEN iffD1]

lemma vlesspollE[elim]:
  assumes "A ≺∘ B" and "A ≲∘ B ⟹ ~(A ≈∘ B) ⟹ P"
  shows P
  using assms by (simp add: vlesspoll_def)

lemma (in v11) v11_vlepollI[intro]: 
  assumes "𝒟∘ r = A" and "ℛ∘ r ⊆∘ B"
  shows "A ≲∘ B" 
  unfolding lepoll_def 
proof(intro exI[of _ ‹λx. r⦇x⦈›] conjI)
  show "inj_on (app r) (elts A)"
    using assms(1) v11.v11_injective v11_axioms by (intro inj_onI) blast
  show "app r ` elts A ⊆ elts B"
    by (intro subsetI) (metis assms(1,2) imageE rev_vsubsetD vdomain_atD)
qed

lemmas v11_vlepollI[intro] = v11.v11_vlepollI

lemma v11_vlepollE[elim]: 
  assumes "A ≲∘ B" 
  obtains f where "v11 f" and "𝒟∘ f = A" and "ℛ∘ f ⊆∘ B"
proof-
  from assms obtain f where "inj_on f (elts A)" and "f ` elts A ⊆ elts B"
    unfolding lepoll_def by auto
  then have "v11 (λa∈∘A. f a)" 
    and "𝒟∘ (λa∈∘A. f a) = A" 
    and "ℛ∘ (λa∈∘A. f a) ⊆∘ B"
    by (auto simp: in_mono vrange_VLambda)
  then show ?thesis using that by simp
qed

text‹\newpage›

end

Theory CZH_Sets_Cardinality

(* Copyright 2021 (C) Mihails Milehins *)

section‹Cardinality›
theory CZH_Sets_Cardinality
  imports 
    CZH_Sets_Nat
    CZH_Sets_Equipollence
begin



subsection‹Background›


text‹
The section presents further results about the cardinality of terms of the type
typ‹V›. The emphasis of this work, however, is on the development of a theory of
finite sets internalized in the type typ‹V›.

Many of the results that are presented in this section were carried over
(with amendments) from the theory ‹Finite› in the main library of Isabelle/HOL.
›

declare One_nat_def[simp del]



subsection‹Cardinality of an arbitrary set›


text‹Elementary properties.›

lemma vcard_veqpoll: "vcard A = vcard B ⟷ A ≈∘ B"
  by (metis cardinal_cong cardinal_eqpoll eqpoll_sym eqpoll_trans)

lemma vcard_vlepoll: "vcard A ≤ vcard B ⟷ A ≲∘ B"
proof
  assume "vcard A ≤ vcard B"
  moreover have "vcard A ≈∘ A" by (rule cardinal_eqpoll)
  moreover have "vcard B ≈∘ B" by (rule cardinal_eqpoll)
  ultimately show "A ≲∘ B"
    by (meson eqpoll_sym lepoll_trans1 lepoll_trans2 vlepoll_vsubset)
qed (simp add: lepoll_imp_Card_le)

lemma vcard_vempty: "vcard A = 0 ⟷ A = 0"
proof-
  have vcard_A: "vcard A ≈∘ A" by (simp add: cardinal_eqpoll)
  then show ?thesis using eq0_iff eqpoll_iff_bijections by metis
qed

lemmas vcard_vemptyD = vcard_vempty[THEN iffD1]
  and vcard_vemptyI = vcard_vempty[THEN iffD2]

lemma vcard_neq_vempty: "vcard A ≠ 0ℕ ⟷ A ≠ 0ℕ"
  using vcard_vempty by auto

lemmas vcard_neq_vemptyD = vcard_neq_vempty[THEN iffD1]
  and vcard_neq_vemptyI = vcard_neq_vempty[THEN iffD2]


text‹Set operations.›

lemma vcard_mono:
  assumes "A ⊆∘ B"
  shows "vcard A ≤ vcard B"
  using assms by (simp add: lepoll_imp_Card_le vlepoll_vsubset)

lemma vcard_vinsert_in[simp]:
  assumes "a ∈∘ A"
  shows "vcard (vinsert a A) = vcard A"
  using assms by (simp add: cardinal_cong insert_absorb)

lemma vcard_vintersection_left: "vcard (A ∩∘ B) ≤ vcard A" 
  by (simp add: vcard_mono)

lemma vcard_vintersection_right: "vcard (A ∩∘ B) ≤ vcard B" 
  by (simp add: vcard_mono)

lemma vcard_vunion: 
  assumes "vdisjnt A B"
  shows "vcard (A ∪∘ B) = vcard A ⊕ vcard B"
  using assms by (rule vcard_disjoint_sup)

lemma vcard_vdiff[simp]: "vcard (A -∘ B) ⊕ vcard (A ∩∘ B) = vcard A"
proof-
  have ABB: "vdisjnt (A -∘ B) (A ∩∘ B)" by auto
  have "A -∘ B ∪∘ A ∩∘ B = A" by auto
  from vcard_vunion[OF ABB, unfolded this] show ?thesis ..
qed

lemma vcard_vdiff_vsubset:
  assumes "B ⊆∘ A"
  shows "vcard (A -∘ B) ⊕ vcard B = vcard A"
  by (metis assms inf.absorb_iff2 vcard_vdiff)


text‹Connections.›

lemma (in vsv) vsv_vcard_vdomain: "vcard (𝒟∘ r) = vcard r"
  unfolding vcard_veqpoll 
proof-
  define f where "f x = ⟨x, r⦇x⦈⟩" for x
  have "bij_betw f (elts (𝒟∘ r)) (elts r)" 
    unfolding f_def bij_betw_def
  proof(intro conjI inj_onI subset_antisym subsetI)
    from vlrestriction_vdomain show 
      "x ∈∘ r ⟹ x ∈ (λx. ⟨x, r⦇x⦈⟩) ` elts (𝒟∘ r)" 
      for x
      unfolding mem_Collect_eq by blast
  qed (auto simp: image_def)
  then show "𝒟∘ r ≈∘ r" unfolding eqpoll_def by auto
qed


text‹Special properties.›

lemma vcard_vunion_vintersection: 
  "vcard (A ∪∘ B) ⊕ vcard (A ∩∘ B) = vcard A ⊕ vcard B"
proof-
  have AB_ABB: "A ∪∘ B = B ∪∘ (A -∘ B)" by auto
  have ABB: "vdisjnt B (A -∘ B)" by auto
  show ?thesis
    unfolding vcard_vunion[OF ABB, folded AB_ABB] cadd_assoc vcard_vdiff
    by (simp add: cadd_commute)
qed



subsection‹Finite sets›

abbreviation vfinite :: "V ⇒ bool" 
  where "vfinite A ≡ finite (elts A)"

lemma vfinite_def: "vfinite A ⟷ (∃n∈∘ω. n ≈∘ A)"  
proof
  assume "finite (elts A)"
  then obtain n :: nat where eltsA: "elts A ≈ {..<n}" 
    by (simp add: eqpoll_iff_card)
  have on: "ord_of_nat n = set (ord_of_nat ` {..<n})"
    by (simp add: ord_of_nat_eq_initial[symmetric])
  from eltsA have "elts A ≈ elts (ord_of_nat n)" 
    unfolding on by (simp add: inj_on_def)
  moreover have "ord_of_nat n ∈∘ ω" by (simp add: ω_def)
  ultimately show "∃n∈∘ω. n ≈∘ A" by (auto intro: eqpoll_sym)
next
  assume "∃n∈∘ω. n ≈∘ A" 
  then obtain n where "n ∈∘ ω" and "n ≈∘ A" by auto
  with eqpoll_finite_iff show "finite (elts A)"
    by (auto intro: finite_Ord_omega)
qed


text‹Rules.›

lemmas vfiniteI[intro!] = vfinite_def[THEN iffD2]  

lemmas vfiniteD[dest!] = vfinite_def[THEN iffD1]

lemma vfiniteE1[elim!]:
  assumes "vfinite A" and "∃n∈∘ω. n ≈∘ A ⟹ P"
  shows P
  using assms by auto

lemma vfiniteE2[elim]:
  assumes "vfinite A" 
  obtains n where "n ∈∘ ω" and "n ≈∘ A"
  using assms by auto


text‹Elementary properties.›

lemma veqpoll_omega_vcard[intro, simp]:
  assumes "n ∈∘ ω" and "n ≈∘ A" 
  shows "vcard A = n"
  using 
    nat_into_Card[OF assms(1), unfolded Card_def] 
    cardinal_cong[OF assms(2)] 
  by simp

lemma (in vsv) vfinite_vimage[intro]:
  assumes "vfinite A"
  shows "vfinite (r `∘ A)"
proof-
  have rA: "r `∘ A = r `∘ (𝒟∘ r ∩∘ A)" by fast
  have DrA: "𝒟∘ r ∩∘ A ⊆∘ 𝒟∘ r" by simp
  show ?thesis by (simp add: inf_V_def assms vimage_image[OF DrA, folded rA])
qed

lemmas [intro] = vsv.vfinite_vimage

lemma vfinite_veqpoll_trans:
  assumes "vfinite A" and "A ≈∘ B" 
  shows "vfinite B"
  using assms by (simp add: eqpoll_finite_iff)

lemma vfinite_vlepoll_trans:
  assumes "vfinite A" and "B ≲∘ A"   
  shows "vfinite B"
  by (meson assms eqpoll_finite_iff finite_lepoll_infinite lepoll_antisym)

lemma vfinite_vlesspoll_trans:
  assumes "vfinite A" and "B ≺∘ A"   
  shows "vfinite B"
  using assms by (auto simp: vlesspoll_def vfinite_vlepoll_trans)


text‹Induction.›

lemma vfinite_induct[consumes 1, case_names vempty vinsert]:
  assumes "vfinite F"
    and "P 0"
    and "⋀x F. ⟦vfinite F; x ∉∘ F; P F⟧ ⟹ P (vinsert x F)"
  shows "P F"
proof-

  from assms(1) obtain n where n: "n ∈∘ ω" and "n ≈∘ F" by clarsimp
  then obtain f'' where bij: "bij_betw f'' (elts n) (elts F)" 
    unfolding eqpoll_def by clarsimp
  define f where "f = (λa∈∘n. f'' a)"
  interpret v11 f 
    unfolding f_def
  proof(intro v11I)
    show "vsv ((λa∈∘n. f'' a)¯∘)"
    proof(intro vsvI)
      fix a b c 
      assume "⟨a, b⟩ ∈∘ (λa∈∘n. f'' a)¯∘" and "⟨a, c⟩ ∈∘ (λa∈∘n. f'' a)¯∘"
      then have "⟨b, a⟩ ∈∘ (λa∈∘n. f'' a)" 
        and "⟨c, a⟩ ∈∘ (λa∈∘n. f'' a)" 
        and "b ∈∘ n" 
        and "c ∈∘ n"
        by auto
      moreover then have "f'' b = f'' c" by auto
      ultimately show "b = c" using bij by (metis bij_betw_iff_bijections)
    qed auto
  qed auto
  have dom_f: "𝒟∘ f = n" unfolding f_def by clarsimp
  have ran_f: "ℛ∘ f = F"
  proof(intro vsubset_antisym vsubsetI)
    fix b assume "b ∈∘ ℛ∘ f"
    then obtain a where "a ∈∘ n" and "b = f'' a" unfolding f_def by auto
    then show "b ∈∘ F" by (meson bij bij_betw_iff_bijections)
  next
    fix b assume "b ∈∘ F"
    then obtain a where "a ∈∘ n" and "b = f'' a" 
      by (metis bij bij_betw_iff_bijections)
    then show "b ∈∘ ℛ∘ f" unfolding f_def by auto
  qed

  define f' where "f' n = f `∘ n" for n
  have F_def: "F = f' n" 
    unfolding f'_def using dom_f ran_f vimage_vdomain by clarsimp
  have "v11 (λa∈∘n. f' a)"
  proof(intro vsv.vsv_valneq_v11I, unfold vdomain_VLambda)
    show "vsv (λa∈∘n. f' a)" by simp
    fix x y assume xD: "x ∈∘ n" and yD: "y ∈∘ n" and xy: "x ≠ y"
    from ‹x ∈∘ n› ‹y ∈∘ n› ‹n ∈∘ ω› have xn: "x ⊆∘ n" and yn: "y ⊆∘ n"
      by (simp_all add: OrdmemD order.strict_implies_order)
    show "(λa∈∘n. f' a)⦇x⦈ ≠ (λa∈∘n. f' a)⦇y⦈"
      unfolding beta[OF xD] beta[OF yD] f'_def
      using xn yn xy 
      by (simp add: dom_f v11_vimage_vpsubset_neq)
  qed

  define P' where "P' n' = (if n' ≤ n then P (f' n') else True)" for n'
  from n have "P' n"
  proof(induct rule: omega_induct)
    case 0 then show ?case 
      unfolding P'_def f'_def using assms(2) by auto
  next
    case (succ k) show ?case 
    proof(cases ‹succ k ≤ n›)
      case True
      then obtain x where xF: "vinsert x (f' k) = (f' (succ k))"
        by (simp add: f'_def succ_def vsubsetD dom_f vsv_vimage_vinsert)
      from True have "k ≤ n" by auto
      with ‹P' k› have "P (f' k)" unfolding P'_def by simp
      then have "f' k ≠ f' (succ k)"
        by (simp add: True f'_def ‹k ≤ n› dom_f v11_vimage_vpsubset_neq)
      with xF have "x ∉∘ f' k" by auto
      have "vfinite (f' k)" 
        by (simp add: ‹k ∈∘ ω› f'_def finite_Ord_omega vfinite_vimage)
      from assms(3)[OF ‹vfinite (f' k)› ‹x ∉∘ f' k› ‹P (f' k)›] show ?thesis 
        unfolding xF P'_def by simp
    qed (unfold P'_def, auto)
  qed  

  then show ?thesis unfolding P'_def F_def by simp

qed


text‹Set operations.›

lemma vfinite_vempty[simp]: "vfinite (0ℕ)" by simp

lemma vfinite_vsingleton[simp]: "vfinite (set {x})" by simp

lemma vfinite_vdoubleton[simp]: "vfinite (set {x, y})" by simp

lemma vfinite_vinsert:
  assumes "vfinite F"
  shows "vfinite (vinsert x F)"
  using assms by simp

lemma vfinite_vinsertD:
  assumes "vfinite (vinsert x F)"
  shows "vfinite F"
  using assms by simp

lemma vfinite_vsubset: 
  assumes "vfinite B" and "A ⊆∘ B" 
  shows "vfinite A"
  using assms
  by (induct arbitrary: A rule: vfinite_induct)
    (simp_all add: less_eq_V_def finite_subset)

lemma vfinite_vunion: "vfinite (A ∪∘ B) ⟷ vfinite A ∧ vfinite B" 
  by (auto simp: elts_sup_iff)

lemma vfinite_vunionI:
  assumes "vfinite A" and "vfinite B"
  shows "vfinite (A ∪∘ B)"
  using assms by (simp add: elts_sup_iff)

lemma vfinite_vunionD:
  assumes "vfinite (A ∪∘ B)" 
  shows "vfinite A" and "vfinite B"
  using assms by (auto simp: elts_sup_iff)

lemma vfinite_vintersectionI:
  assumes "vfinite A" and "vfinite B"
  shows "vfinite (A ∩∘ B)"
  using assms by (simp add: vfinite_vsubset)

lemma vfinite_VPowI: 
  assumes "vfinite A"
  shows "vfinite (VPow A)"
  using assms
proof(induct rule: vfinite_induct)
  case vempty then show ?case by simp
next
  case (vinsert x F)
  then show ?case 
    unfolding VPow_vinsert 
    using rel_VLambda.vfinite_vimage 
    by (intro vfinite_vunionI) metis+
qed


text‹Connections.›

lemma vfinite_vcard_vfinite: "vfinite (vcard A) = vfinite A" 
  by (simp add: cardinal_eqpoll eqpoll_finite_iff)

lemma vfinite_vcard_omega_iff: "vfinite A ⟷ vcard A ∈∘ ω" 
   using vfinite_vcard_vfinite by auto

lemmas vcard_vfinite_omega = vfinite_vcard_omega_iff[THEN iffD2]
  and vfinite_vcard_omega = vfinite_vcard_omega_iff[THEN iffD1]

lemma vfinite_csucc[intro, simp]:
  assumes "vfinite A"
  shows "csucc (vcard A) = succ (vcard A)"
  using assms by (force simp: finite_csucc)

lemmas [intro, simp] = finite_csucc


text‹Previous connections.›

lemma vcard_vsingleton[simp]: "vcard (set {a}) = 1ℕ" by auto

lemma vfinite_vcard_vinsert_nin[simp]:
  assumes "vfinite A" and "a ∉∘ A"
  shows "vcard (vinsert a A) = csucc (vcard A)"
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

text‹\newpage›

end

Theory CZH_Sets_Ordinals

(* Copyright 2021 (C) Mihails Milehins *)

section‹Further results about ordinal numbers›
theory CZH_Sets_Ordinals
  imports 
    CZH_Sets_Nat
    CZH_Sets_IF
    Complex_Main
begin



subsection‹Background›


text‹
The subsection presents several results about ordinal 
numbers. The primary general reference for this section 
is \cite{takeuti_introduction_1971}.
›

lemmas [intro] = Limit_is_Ord Ord_in_Ord



subsection‹Further ordinal arithmetic and inequalities›


lemma Ord_succ_mono:
  assumes "Ord β" and "α ∈∘ β"
  shows "succ α ∈∘ succ β"
proof-
  from assms have "Ord α" by blast
  from assms ‹Ord α› have "α < β" by (auto dest: Ord_mem_iff_lt)
  from assms(1,2) this have "succ α < succ β"
    by (meson assms ‹Ord α› Ord_linear2 Ord_succ leD le_succ_iff)
  with assms(1) ‹Ord α› Ord_mem_iff_lt show "succ α ∈∘ succ β" by blast
qed

lemma Limit_right_Limit_mult:
  ―‹Based on Theorem 8.23 in \cite{takeuti_introduction_1971}.›
  assumes "Ord α" and "Limit β" and "0 ∈∘ α" 
  shows "Limit (α * β)"
proof-
  have αβ: "α * β = (⋃∘ξ∈∘β. α * ξ)" by (rule mult_Limit[OF assms(2), of α])
  from assms(1,2) Ord_mult have "Ord (α * β)" by blast
  then show ?thesis 
  proof(cases rule: Ord_cases)
    case (succ γ)
    from succ(1) have "γ ∈∘ α * β" unfolding succ(2)[symmetric] by simp
    then obtain ξ where "ξ ∈∘ β" and "γ ∈∘ α * ξ" unfolding αβ by auto
    moreover with assms(2) have "Ord ξ" by auto
    ultimately have sγ_sαξ: "succ γ ∈∘ succ (α * ξ)"
      using assms(1) Ord_succ_mono by simp
    from assms(2,3) have "succ (α * ξ) ⊆∘ α * ξ + α" 
      unfolding succ_eq_add1 by force
    with sγ_sαξ have "succ γ ∈∘ α * succ ξ" 
      unfolding mult_succ[symmetric] by auto
    moreover have "succ ξ ∈∘ β" 
      by (simp add: succ_in_Limit_iff ‹ξ ∈∘ β› assms(2))
    ultimately have "succ γ ∈∘ α * β" unfolding αβ by force
    with succ(2) show ?thesis by simp
  qed (use assms(2,3) in auto)
qed

lemma Limit_left_Limit_mult:
  assumes "Limit α" and "Ord β" and "0 ∈∘ β" 
  shows "Limit (α * β)"
proof(cases ‹Limit β›)
  case False
  then obtain β' where "Ord β'" and β_def: "β = succ β'" 
    by (metis Ord_cases assms(2,3) eq0_iff)
  have α_sβ': "α * succ β' = α * β' + α" by (simp add: mult_succ)
  from assms(1) have "Limit (α * β' + α)" by (simp add: Limit_is_Ord ‹Ord β'›)
  then show "Limit (α * β)" unfolding β_def α_sβ' by simp
qed (use assms in ‹auto simp: Limit_def dest: Limit_right_Limit_mult›)

lemma zero_if_Limit_eq_Limit_plus_vnat:
  assumes "Limit α" and "Limit β" and "α = β + n" and "n ∈∘ ω"
  shows "n = 0"
proof(rule ccontr)
  assume prems: "n ≠ 0"
  from assms(1,2,4) have "Ord α" and "Ord β" and "Ord 0" and "Ord n" by auto
  have "0 ∈∘ n" by (simp add: mem_0_Ord prems assms(4)) 
  with assms(4) obtain m where n_def: "n = succ m" by (auto elim: omega_prev)
  from assms(1,3) show False by (simp add: n_def plus_V_succ_right)
qed

lemma Ord_vsubset_closed: 
  assumes "Ord α" and "Ord γ" and "α ⊆∘ β" and "β ∈∘ γ" 
  shows "α ∈∘ γ" 
proof-
  from assms have "Ord β" by auto
  with assms show ?thesis by (simp add: Ord_mem_iff_lt)
qed

lemma
  ―‹Based on Exercise 1, page 53 in \cite{takeuti_introduction_1971}.›
  assumes "Ord α" and "Ord γ" and "α + β ∈∘ γ" 
  shows Ord_plus_Ord_closed_augend: "α ∈∘ γ" 
    and Ord_plus_Ord_closed_addend: "β ∈∘ γ"
proof-
  from assms have "α + β ∈∘ α + γ" by (meson vsubsetD add_le_left)
  from add_mem_right_cancel[THEN iffD1, OF this] show "β ∈∘ γ" .
  from assms have "α ⊆∘ α + β" by simp
  from Ord_vsubset_closed[OF assms(1,2) this assms(3)] show "α ∈∘ γ" .
qed

lemma Ord_ex1_Limit_plus_in_omega:
  ―‹Based on Theorem 8.13 in \cite{takeuti_introduction_1971}.›
  assumes "Ord α" and "ω ⊆∘ α"
  shows "∃!β. ∃!n. n ∈∘ ω ∧ Limit β ∧ α = β + n"
proof-
  let ?A = ‹set {γ. Limit γ ∧ γ ⊆∘ α}›
  have small[simp]: "small {γ. Limit γ ∧ γ ⊆∘ α}"
  proof-
    from Ord_mem_iff_lt  have "{γ. Limit γ ∧ γ ⊆∘ α} ⊆ elts (succ α)"
      by (auto dest: order.not_eq_order_implies_strict intro: assms(1))
    then show "small {γ. Limit γ ∧ γ ⊆∘ α}" by (meson down)
  qed
  let ?β = ‹⋃∘?A›
  have "?β ⊆∘ α" by auto
  moreover have L_β: "Limit ?β"
  proof(subst Limit_def, intro conjI allI impI)
    show "Ord ?β" by (fastforce intro: Ord_Sup)
    from assms(2) show "0 ∈∘ ?β" by auto
    fix y assume "y ∈∘ ?β"
    then obtain γ where "y ∈∘ γ" and "γ ∈∘ ?A" by clarsimp
    then show "succ y ∈∘ ?β" by (auto simp: succ_in_Limit_iff)
  qed
  ultimately obtain γ where "Ord γ" and α_def: "α = ?β + γ"
    by (metis assms(1) le_Ord_diff Limit_is_Ord)
  from L_β have L_βω: "Limit (?β + ω)" by (blast intro: Limit_add_Limit)
  have "γ ⊂∘ ω"
  proof(rule ccontr)
    assume "~γ ⊂∘ ω"
    with ‹Ord γ› Ord_linear2 have "ω ⊆∘ γ" by auto
    then obtain δ where γ_def: "γ = ω + δ" 
      by (blast dest: Ord_odiff_eq intro: ‹Ord γ›)
    from α_def have "α = (?β + ω) + δ" by (simp add: add.assoc γ_def)
    then have "?β + ω ⊆∘ α" by (metis add_le_cancel_left0)
    with L_βω have "?β + ω ⊆∘ ?β" by auto
    with add_le_cancel_left[of ?β ω 0, THEN iffD1] show False by simp
  qed
  with α_def have "γ ∈∘ ω" by (auto simp: Ord_mem_iff_lt ‹Ord γ›)
  show ?thesis
  proof
    (
      intro ex1I conjI; 
      (elim conjE ex1E allE conjE impE | tactic‹all_tac›);
      (intro conjI | tactic‹all_tac›)
    )
    show "γ ∈∘ ω" by (rule ‹γ ∈∘ ω›)
    show "Limit ?β" by (rule ‹Limit ?β›)
    show "α = ?β + γ" by (rule α_def)
    from α_def show "α = ?β + n ⟹ n = γ" for n by auto
    show "n ∈∘ ω ⟹ Limit β ⟹ α = β + n ⟹ β = ?β" for n β
    proof-
      assume prems: "n ∈∘ ω" "Limit β" "α = β + n"
      from L_β prems(2,3) have "β ⊆∘ ?β" by auto
      then obtain η where β_def: "?β = β + η" and "Ord η" 
        by (metis (lifting) L_β Limit_is_Ord le_Ord_diff prems(2))
      moreover have "η ∈∘ ω"
      proof-
        from α_def β_def have "β + η + γ = β + n" by (simp add: prems(3))
        then have "η + γ = n" by (simp add: add.assoc)
        with ‹γ ∈∘ ω› ‹n ∈∘ ω› ‹Ord γ› show "η ∈∘ ω"
          by (blast intro: calculation(2) Ord_plus_Ord_closed_augend)
      qed
      ultimately show ?thesis 
        using prems(2) L_β by (force dest: zero_if_Limit_eq_Limit_plus_vnat)
    qed      
  qed 
qed

lemma not_Limit_if_in_Limit_plus_omega:
  assumes "Limit α" and "α ∈∘ β" and "β ∈∘ α + ω"
  shows "~Limit β"
proof-
  from assms Ord_add have "Ord β" by blast
  show ?thesis
    using assms(3)
  proof(cases rule: mem_plus_V_E)
    case 1 with mem_not_sym show ?thesis by (auto simp: assms(2,3))
  next
    case (2 z)
    from zero_if_Limit_eq_Limit_plus_vnat[OF _ assms(1) 2(2) 2(1)] 2(2) assms(2) 
    show ?thesis  
      by force
  qed
qed

lemma Limit_plus_omega_vsubset_Limit: 
  assumes "Limit α" and "Limit β" and "α ∈∘ β"
  shows "α + ω ⊆∘ β"
proof- 
  from assms(1) have Lαω: "Limit (α + ω)" by (simp add: Limit_is_Ord)
  from not_Limit_if_in_Limit_plus_omega[OF assms(1,3)] assms(2) have
    "β ∉∘ α + ω"
    by clarsimp
  with assms(2) have "~β ⊂∘ α + ω"
    by (blast intro: Lαω dest: Ord_mem_iff_lt Limit_is_Ord)
  then show "α + ω ⊆∘ β" by (meson assms Lαω Limit_is_Ord Ord_linear2)
qed

lemma Limit_plus_nat_in_Limit:
  assumes "Limit α" and "Limit β" and "α ∈∘ β"
  shows "α + aℕ ∈∘ β"
  using assms Limit_plus_omega_vsubset_Limit[OF assms] by auto

lemma omega2_vsubset_Limit:
  assumes "Limit α" and "ω ∈∘ α"
  shows "ω + ω ⊆∘ α"
  using assms by (simp add: Limit_plus_omega_vsubset_Limit)

text‹\newpage›

end

Theory CZH_Sets_FSequences

(* Copyright 2021 (C) Mihails Milehins *)

section‹Finite sequences›
theory CZH_Sets_FSequences
  imports CZH_Sets_Cardinality
begin



subsection‹Background›


text‹
The section presents a theory of finite sequences internalized in the 
type typ‹V›. The content of this subsection
was inspired by and draws on many ideas from the content
of the theory ‹List› in the main library of Isabelle/HOL.
›



subsection‹Definition and common properties›


text‹
A finite sequence is defined as a single-valued binary relation whose domain 
is an initial segment of the set of natural numbers.
›

locale vfsequence = vsv xs for xs +
  assumes vfsequence_vdomain_in_omega: "𝒟∘ xs ∈∘ ω"

locale vfsequence_pair = r1: vfsequence xs1 + r2: vfsequence xs2 for xs1 xs2


text‹Rules.›

lemmas [intro] = vfsequence.axioms(1)

lemma vfsequenceI[intro]:
  assumes "vsv xs" and "𝒟∘ xs ∈∘ ω"
  shows "vfsequence xs"
  using assms by (simp add: vfsequence.intro vfsequence_axioms_def)

lemma vfsequenceD[dest]:
  assumes "vfsequence xs"
  shows "𝒟∘ xs ∈∘ ω"
  using assms vfsequence.vfsequence_vdomain_in_omega by simp

lemma vfsequenceE[elim]:
  assumes "vfsequence xs" and "𝒟∘ xs ∈∘ ω ⟹ P"
  shows P
  using assms by auto

lemma vfsequence_iff: "vfsequence xs ⟷ vsv xs ∧ 𝒟∘ xs ∈∘ ω"
  using vfsequence_def by auto


text‹Elementary properties.›

lemma (in vfsequence) vfsequence_vdomain: "𝒟∘ xs = vcard xs"
  unfolding vsv_vcard_vdomain[symmetric] using vfsequence_vdomain_in_omega by simp

lemma (in vfsequence) vfsequence_vcard_in_omega[simp]: "vcard xs ∈∘ ω"
  using vfsequence_vdomain_in_omega by (simp add: vfsequence_vdomain)


text‹Set operations.›

lemma vfsequence_vempty[intro, simp]: "vfsequence 0" by (simp add: vfsequenceI)

lemma vfsequence_vsingleton[intro, simp]: "vfsequence (set {⟨0, a⟩})"  
  using vone_in_omega 
  unfolding one_V_def 
  by (intro vfsequenceI) (auto simp: set_vzero_eq_ord_of_nat_vone)

lemma (in vfsequence) vfsequence_vinsert: 
  "vfsequence (vinsert ⟨vcard xs, a⟩ xs)"
  using succ_def succ_in_omega by (auto simp: vfsequence_vdomain)


text‹Connections.›

lemma (in vfsequence) vfsequence_vfinite[simp]: "vfinite xs"
  by (simp add: vfinite_vcard_omega_iff)

lemma (in vfsequence) vfsequence_vlrestriction[intro, simp]:
  assumes "k ∈∘ ω"
  shows "vfsequence (xs ↾l∘ k)"
  using assms by (force simp: vfsequence_vdomain vdomain_vlrestriction)

lemma vfsequence_vproduct: 
  assumes "n ∈∘ ω" and "xs ∈∘ (∏∘i∈∘n. A i)"
  shows "vfsequence xs"
  using assms by auto

lemma vfsequence_vcpower: 
  assumes "n ∈∘ ω" and "xs ∈∘ A ^× n"
  shows "vfsequence xs"
  using assms vfsequence_vproduct by auto


text‹Special properties.›

lemma (in vfsequence) vfsequence_vdomain_vlrestriction[intro, simp]: 
  assumes "k ∈∘ vcard xs"
  shows "𝒟∘ (xs ↾l∘ k) = k"
  using assms
  by 
    (
      simp add: 
        OrdmemD 
        inf_absorb2   
        order.strict_implies_order 
        vdomain_vlrestriction 
        vfsequence_vdomain
    )

lemma (in vfsequence) vfsequence_vlrestriction_vcard[simp]: 
  "xs ↾l∘ (vcard xs) = xs"
  by (rule vlrestriction_vdomain[unfolded vfsequence_vdomain])

lemma vfsequence_vfinite_vcardI:
  assumes "vsv xs" and "vfinite xs" and "𝒟∘ xs = vcard xs"
  shows "vfsequence xs"
  using assms by (intro vfsequenceI) (auto simp: vfinite_vcard_omega)

lemma (in vfsequence) vfsequence_vrangeE:
  assumes "a ∈∘ ℛ∘ xs" 
  obtains n where "n ∈∘ vcard xs" and "xs⦇n⦈ = a"
  using assms vfsequence_vdomain by auto

lemma (in vfsequence) vfsequence_vrange_vproduct:
  assumes "⋀i. i ∈∘ vcard xs ⟹ xs⦇i⦈ ∈∘ A i" 
  shows "xs ∈∘ (∏∘i∈∘vcard xs. A i)"
  using vfsequence_vdomain vsv_axioms assms 
  by 
    (
      intro vproductI; 
      (intro vsv.vsv_vrange_vsubset_vifunion_app | tactic‹all_tac›)
    ) auto

lemma (in vfsequence) vfsequence_vrange_vcpower:
  assumes "ℛ∘ xs ⊆∘ A"
  shows "xs ∈∘ A ^× (vcard xs)"
  using assms
proof(elim vsubsetE; intro vcpowerI)
  assume hyp: "x ∈∘ ℛ∘ xs ⟹ x ∈∘ A" for x
  from vfsequence_vdomain show "xs ∈∘ (∏∘i∈∘vcard xs. A)"
    by (intro vproductI) (blast intro: hyp elim: vdomain_atE)+
qed


text‹Alternative forms of existing results.›

lemmas [intro, simp] = vfsequence.vfsequence_vcard_in_omega 
  and [intro, simp] = vfsequence.vfsequence_vfinite
  and [intro, simp] = vfsequence.vfsequence_vlrestriction
  and [intro, simp] = vfsequence.vfsequence_vdomain_vlrestriction
  and [intro, simp] = vfsequence.vfsequence_vlrestriction_vcard



subsection‹Appending an element to a finite sequence: ‹vcons››


subsubsection‹Definition and common properties›

definition vcons :: "V ⇒ V ⇒ V"  (infixr ‹#∘› 65) 
  where "xs #∘ x = vinsert ⟨vcard xs, x⟩ xs"


text‹Syntax.›

abbreviation vempty_vfsequence (‹[]∘›) where 
  "vempty_vfsequence ≡ 0::V"

notation vempty_vfsequence (‹[]∘›)

nonterminal fsfields
nonterminal vlist

syntax
  "" :: "V ⇒ fsfields" ("_")
  "_fsfields" :: "fsfields ⇒ V ⇒ fsfields" ("_,/ _")
  "_vlist" :: "fsfields ⇒ V" ("[(_)]∘")
  "_vapp" :: "V ⇒ fsfields ⇒ V" ("_ ⦇(_)⦈∙" [100, 100] 100)

translations
  "[xs, x]∘" == "[xs]∘ #∘ x"
  "[x]∘" == "[]∘ #∘ x"

translations
  "f⦇xs, x⦈∙" == "f⦇[xs, x]∘⦈"
  "f⦇x⦈∙" == "f⦇[x]∘⦈"


text‹Rules.›

lemma vconsI[intro!]: 
  assumes "a ∈∘ vinsert ⟨vcard xs, x⟩ xs"
  shows "a ∈∘ xs #∘ x"
  using assms unfolding vcons_def by clarsimp

lemma vconsD[dest!]:
  assumes "a ∈∘ xs #∘ x"
  shows "a ∈∘ vinsert ⟨vcard xs, x⟩ xs"
  using assms unfolding vcons_def by clarsimp

lemma vconsE[elim!]:
  assumes "a ∈∘ xs #∘ x"
  obtains a where "a ∈∘ vinsert ⟨vcard xs, x⟩ xs"
  using assms unfolding vcons_def by clarsimp


text‹Elementary properties.›

lemma vcons_neq_vempty[simp]: "ys #∘ y ≠ []∘" by auto


text‹Set operations.›

lemma vcons_vsingleton: "[a]∘ = set {⟨0ℕ, a⟩}" unfolding vcons_def by simp

lemma vcons_vdoubleton: "[a, b]∘ = set {⟨0ℕ, a⟩, ⟨1ℕ, b⟩}" 
  unfolding vcons_def 
  using vinsert_vsingleton 
  by (force simp: vinsert_set_insert_eq)

lemma vcons_vsubset: "xs ⊆∘ xs #∘ x" by clarsimp

lemma vcons_vsubset':
  assumes "vcons xs x ⊆∘ ys"
  shows "vcons xs x ⊆∘ vcons ys y"
  using assms unfolding vcons_def by auto


text‹Connections.›

lemma (in vfsequence) vfsequence_vcons[intro, simp]: "vfsequence (xs #∘ x)"
proof(intro vfsequenceI)
  from vfsequence_vdomain_in_omega vsv_vcard_vdomain have "vcard xs = 𝒟∘ xs" 
    by (simp add: vcard_veqpoll)
  show "vsv (xs #∘ x)" 
  proof(intro vsvI)
    fix a b c assume ab: "⟨a, b⟩ ∈∘ xs #∘ x" and ac: "⟨a, c⟩ ∈∘ xs #∘ x" 
    then consider (dom) "a ∈∘ 𝒟∘ xs" | (ndom) "a = vcard xs"
      unfolding vcons_def by auto
    then show "b = c"
    proof cases
      case dom
      with ab have "⟨a, b⟩ ∈∘ xs" 
        unfolding vcons_def by (auto simp: ‹vcard xs = 𝒟∘ xs›)
      moreover from dom ac have "⟨a, c⟩ ∈∘ xs" 
        unfolding vcons_def by (auto simp: ‹vcard xs = 𝒟∘ xs›)
      ultimately show ?thesis using vsv by simp
    next
      case ndom
      from ab have "⟨a, b⟩ = ⟨vcard xs, x⟩" 
        unfolding ndom vcons_def using ‹vcard xs = 𝒟∘ xs› mem_not_refl by blast
      moreover from ac have "⟨a, c⟩ = ⟨vcard xs, x⟩" 
        unfolding ndom vcons_def using ‹vcard xs = 𝒟∘ xs› mem_not_refl by blast
      ultimately show ?thesis by simp
    qed
  next
    show "vbrelation (xs #∘ x)" unfolding vcons_def
      using vbrelation_vinsertI by auto
  qed                     
  show "𝒟∘ (xs #∘ x) ∈∘ ω"
    unfolding vcons_def 
    using succ_in_omega  
    by (auto simp: vfsequence_vdomain_in_omega succ_def ‹vcard xs = 𝒟∘ xs›)
qed

lemma (in vfsequence) vfsequence_vcons_vdomain[simp]: 
  "𝒟∘ (xs #∘ x) = succ (vcard xs)"
  by (simp add: succ_def vcons_def vfsequence_vdomain)

lemma (in vfsequence) vfsequence_vcons_vrange[simp]: 
  "ℛ∘ (xs #∘ x) = vinsert x (ℛ∘ xs)"
  by (simp add: vcons_def)

lemma (in vfsequence) vfsequence_vrange_vconsI:
  assumes "ℛ∘ xs ⊆∘ X" and "x ∈∘ X"
  shows "ℛ∘ (xs #∘ x) ⊆∘ X"
  using assms unfolding vcons_def by auto

lemmas vfsequence_vrange_vconsI = vfsequence.vfsequence_vrange_vconsI[rotated 1]


text‹Special properties.›

lemma vcons_vrange_mono:
  assumes "xs ⊆∘ ys"
  shows "ℛ∘ (xs #∘ x) ⊆∘ ℛ∘ (ys #∘ x)"
  using assms 
  unfolding vcons_def 
  by (simp add: vrange_mono vsubset_vinsert_leftI vsubset_vinsert_rightI)

lemma (in vfsequence) vfsequence_vlrestriction_succ:
  assumes [simp]: "k ∈∘ vcard xs"
  shows "xs ↾l∘ succ k = xs ↾l∘ k #∘ (xs⦇k⦈)"
proof-
  interpret vlr: vfsequence ‹xs ↾l∘ k›
    using assms by (blast intro: vfsequence_vcard_in_omega Ord_trans)
  from vlr.vfsequence_vdomain[symmetric, simplified] show ?thesis 
    by 
      (
        simp add: 
          vcons_def succ_def vfsequence_vdomain vsv_vlrestriction_vinsert
      )
qed

lemma (in vfsequence) vfsequence_vremove_vcons_vfsequence: 
  assumes "xs = xs' #∘ x"
  shows "vfsequence xs'"
proof(cases‹⟨vcard xs', x⟩ ∈∘ xs'›)
  case True
  with assms[unfolded vcons_def] have "xs = xs'" by auto
  then show ?thesis using vfsequence_axioms by simp
next
  case False
  note x_def[simp] = assms[unfolded vcons_def]
  interpret xs': vsv xs' using vsv_axioms by (auto intro: vsv_vinsertD)
  have fin: "vfinite xs'" using vfsequence_vfinite by auto
  have vcard_xs: "vcard xs = succ (vcard xs')" by (simp add: fin False)
  have [simp]: "vcard xs' ∉∘ 𝒟∘ xs'" using False vsv_axioms by auto
  have "vcard xs' ∈∘ ω" using fin vfinite_vcard_omega by auto
  have xs'_def: "xs' = xs ↾l∘ (vcard xs')" 
    using vcard_xs fin vfsequence_vdomain 
    by (auto simp: vinsert_ident succ_def)
  from vfsequence_vlrestriction[OF ‹vcard xs' ∈∘ ω›] show ?thesis 
    unfolding xs'_def[symmetric] .
qed

lemma (in vfsequence) vfsequence_vcons_ex: 
  assumes "xs ≠ []∘" 
  obtains xs' x where "xs = xs' #∘ x" and "vfsequence xs'"
proof-
  from vcard_vempty have "0 ∈∘ vcard xs" by (simp add: assms mem_0_Ord)
  then obtain k where succk: "succ k = vcard xs"
    by (metis omega_prev vfsequence_vcard_in_omega) 
  then have "k ∈∘ vcard xs" using elts_succ by blast
  from vfsequence_vlrestriction_succ[OF this, unfolded succk] show ?thesis
    by (simp add: vfsequence_vremove_vcons_vfsequence that)
qed


subsubsection‹Induction and case analysis›

lemma vfsequence_induct[consumes 1, case_names 0 vcons]:
  assumes "vfsequence xs"
    and "P []∘"
    and "⋀xs x. ⟦vfsequence xs; P xs⟧ ⟹ P (xs #∘ x)"
  shows "P xs"
proof-
  interpret vfsequence xs by (rule assms(1))
  from assms(1) obtain n where "n ∈∘ ω" and "𝒟∘ xs = n" by auto
  then have "n ≤ 𝒟∘ xs" by auto
  define P' where "P' k = P (xs ↾l∘ k)" for k
  from ‹n ∈∘ ω› and ‹n ≤ 𝒟∘ xs› have "P' n"
  proof(induction rule: omega_induct)
    case (succ n') then show ?case
    proof-
      interpret vlr: vfsequence ‹xs ↾l∘ n'› by (simp add: succ.hyps)
      have "P' n'" using succ.prems by (force intro: succ.IH)
      then have "P (xs ↾l∘ n')" unfolding P'_def by assumption
      have "n' ∈∘ vcard xs" 
        using succ.prems by (auto simp: vsubset_iff vfsequence_vdomain)
      from vfsequence_vlrestriction_succ[OF ‹n' ∈∘ vcard xs›]
      show "P' (succ n')"
        by (simp add: P'_def ‹P (xs ↾l∘ n')› assms(3) vlr.vfsequence_axioms)
    qed
  qed (simp add: P'_def assms(2))
  then show ?thesis unfolding P'_def ‹𝒟∘ xs = n›[symmetric] by simp
qed

lemma vfsequence_cases[consumes 1, case_names 0 vcons]: 
  assumes "vfsequence xs"
    and "xs = []∘ ⟹ P"
    and "⋀xs' x. ⟦xs = xs' #∘ x; vfsequence xs'⟧ ⟹ P"
  shows P
proof-
  interpret vfsequence xs by (rule assms(1))
  show ?thesis
  proof(cases ‹xs = 0›)
    case False
    then obtain xs' x where "xs = xs' #∘ x"
      by (blast intro: vfsequence_vcons_ex)
    then show ?thesis by (auto simp: assms(3) intro: vfsequence_vcons_ex)
  qed (use assms(2) in auto)
qed


subsubsection‹Evaluation›

lemma (in vfsequence) vfsequence_vcard_vcons[simp]: 
  "vcard (xs #∘ x) = succ (vcard xs)"
proof-
  interpret xsx: vfsequence ‹xs #∘ x› by simp
  have "vcard (xs #∘ x) = 𝒟∘ (xs #∘ x)" 
    by (rule xsx.vfsequence_vdomain[symmetric])
  then show ?thesis
    by (subst vcons_def) (simp add: succ_def vcons_def vfsequence_vdomain)
qed

lemma (in vfsequence) vfsequence_at_last[intro, simp]:
  assumes "i = vcard xs"
  shows "(xs #∘ x)⦇i⦈ = x"
  by (simp add: vfsequence_vdomain vcons_def assms)

lemma (in vfsequence) vfsequence_at_not_last[intro, simp]:
  assumes "i ∈∘ vcard xs"
  shows "(xs #∘ x)⦇i⦈ = xs⦇i⦈"
proof-
  from assms have [simp]: "𝒟∘ xs = vcard xs" by (auto simp: vfsequence_vdomain)
  from assms have "i ∈∘ 𝒟∘ xs" by simp
  moreover have "i ≠ vcard xs" using assms mem_not_refl by blast
  ultimately show ?thesis
    unfolding vcons_def using vsv.vsv_vinsert vsvE vsv_axioms by auto 
qed


text‹Alternative forms of existing results.›

lemmas [intro, simp] = vfsequence.vfsequence_vcons
  and [intro, simp] = vfsequence.vfsequence_vcard_vcons
  and [intro, simp] = vfsequence.vfsequence_at_last
  and [intro, simp] = vfsequence.vfsequence_at_not_last
  and [intro, simp] = vfsequence.vfsequence_vcons_vdomain
  and [intro, simp] = vfsequence.vfsequence_vcons_vrange



subsubsection‹Congruence-like properties›

context vfsequence_pair
begin

lemma vcons_eq_vcard_eq:
  assumes "xs1 #∘ x1 = xs2 #∘ x2"
  shows "vcard xs1 = vcard xs2"
  by 
    (
      metis 
        assms 
        succ_inject_iff   
        vfsequence.vfsequence_vcons_vdomain
        r1.vfsequence_axioms 
        r2.vfsequence_axioms
    )

lemma vcons_eqD[dest]:
  assumes "xs1 #∘ x1 = xs2 #∘ x2"
  shows "xs1 = xs2" and "x1 = x2"
proof-

  have xsx1_last: "(xs1 #∘ x1)⦇vcard xs1⦈ = x1" by simp
  have xsx2_last: "(xs2 #∘ x2)⦇vcard xs2⦈ = x2" by simp

  from assms have vcard: "vcard xs1 = vcard xs2" by (rule vcons_eq_vcard_eq)
  from trans[OF xsx1_last xsx1_last[unfolded vcard assms, symmetric]]
  
  show "x1 = x2" unfolding xsx1_last xsx2_last .

  have nxs1: "⟨vcard xs1, x1⟩ ∉∘ xs1" 
    using mem_not_refl r1.vfsequence_vdomain by blast
  have nxs2: "⟨vcard xs2, x2⟩ ∉∘ xs2" 
    using mem_not_refl r2.vfsequence_vdomain by blast
  have xsx1_xsx2: "⟨vcard xs1, x1⟩ = ⟨vcard xs2, x2⟩" 
    unfolding vcons_eq_vcard_eq[OF assms(1)] ‹x1 = x2› by simp
  
  show "xs1 = xs2"
  proof(rule vinsert_identD[OF _ nxs1])
    from assms(1)[unfolded vcons_def] show 
      "vinsert ⟨vcard xs1, x1⟩ xs1 = vinsert ⟨vcard xs1, x1⟩ xs2"
      by (auto simp: xsx1_xsx2)
    show "⟨vcard xs1, x1⟩ ∉∘ xs2"
      by (rule nxs2[folded ‹x1 = x2› vcons_eq_vcard_eq[OF assms(1)]])
  qed

qed

lemma vcons_eqI:
  assumes "xs1 = xs2" and "x1 = x2"
  shows "xs1 #∘ x1 = xs2 #∘ x2"
  using assms by (rule arg_cong2)

lemma vcons_eq_iff[simp]: "(xs1 #∘ x1 = xs2 #∘ x2) ⟷ (xs1 = xs2 ∧ x1 = x2)" 
  by auto

end


text‹Alternative forms of existing results.›

context
  fixes xs1 xs2
  assumes xs1: "vfsequence xs1"
    and xs2: "vfsequence xs2"
begin

lemmas_with[OF vfsequence_pair.intro[OF xs1 xs2]]:
  vcons_eqD' = vfsequence_pair.vcons_eqD
  and vcons_eq_iff[intro, simp] = vfsequence_pair.vcons_eq_iff

end

lemmas vcons_eqD[dest] = vcons_eqD'[rotated -1]



subsection‹Transfer between the type typ‹V list› and finite sequences›


subsubsection‹Initialization›

primrec vfsequence_of_vlist :: "V list ⇒ V"
  where 
    "vfsequence_of_vlist [] = 0"
  | "vfsequence_of_vlist (x # xs) = vfsequence_of_vlist xs #∘ x"

definition vlist_of_vfsequence :: "V ⇒ V list"
  where "vlist_of_vfsequence = inv_into UNIV vfsequence_of_vlist"

lemma vfsequence_vfsequence_of_vlist: "vfsequence (vfsequence_of_vlist xs)"
  by (induction xs) auto

lemma inj_vfsequence_of_vlist: "inj vfsequence_of_vlist"
proof
  show "vfsequence_of_vlist x = vfsequence_of_vlist y ⟹ x = y" 
    for x y
  proof(induction y arbitrary: x)
    case Nil then show ?case by (cases x) auto
  next
    case (Cons a ys)
    note Cons' = Cons
    show ?case 
    proof(cases x)
      case Nil with Cons show ?thesis by auto
    next
      case (Cons b zs)
      from Cons'[unfolded Cons vfsequence_of_vlist.simps] have 
        "vfsequence_of_vlist zs #∘ b = vfsequence_of_vlist ys #∘ a"
        by simp
      then have "vfsequence_of_vlist zs = vfsequence_of_vlist ys" and "b = a"
        by (auto simp: vfsequence_vfsequence_of_vlist)
      from Cons'(1)[OF this(1)] this(2) show ?thesis unfolding Cons by auto
    qed
  qed
qed

lemma range_vfsequence_of_vlist: 
  "range vfsequence_of_vlist = {xs. vfsequence xs}"
proof(intro subset_antisym subsetI; unfold mem_Collect_eq)
  show "xs ∈ range vfsequence_of_vlist ⟹ vfsequence xs" for xs
    by (clarsimp simp: vfsequence_vfsequence_of_vlist)
  fix xs assume "vfsequence xs"
  then show "xs ∈ range vfsequence_of_vlist"
  proof(induction rule: vfsequence_induct)
    case 0 then show ?case 
      by (metis image_iff iso_tuple_UNIV_I vfsequence_of_vlist.simps(1))
  next
    case (vcons xs x) then show ?case 
      by (metis rangeE rangeI vfsequence_of_vlist.simps(2))
  qed 
qed

lemma vlist_of_vfsequence_vfsequence_of_vlist[simp]: 
  "vlist_of_vfsequence (vfsequence_of_vlist xs) = xs"
  by (simp add: inj_vfsequence_of_vlist vlist_of_vfsequence_def)

lemma (in vfsequence) vfsequence_of_vlist_vlist_of_vfsequence[simp]: 
  "vfsequence_of_vlist (vlist_of_vfsequence xs) = xs"
  using vfsequence_axioms range_vfsequence_of_vlist inj_vfsequence_of_vlist
  by (simp add: f_inv_into_f vlist_of_vfsequence_def)

lemmas vfsequence_of_vlist_vlist_of_vfsequence[intro, simp] =
  vfsequence.vfsequence_of_vlist_vlist_of_vfsequence

lemma vlist_of_vfsequence_vempty[simp]: "vlist_of_vfsequence []∘ = []"
  by 
    (
      metis 
        vfsequence_of_vlist.simps(1) 
        vlist_of_vfsequence_vfsequence_of_vlist
    )


text‹Transfer relation 1.›

definition cr_vfsequence :: "V ⇒ V list ⇒ bool"
  where "cr_vfsequence a b ⟷ (a = vfsequence_of_vlist b)"

lemma cr_vfsequence_right_total[transfer_rule]: "right_total cr_vfsequence"
  unfolding cr_vfsequence_def right_total_def by simp

lemma cr_vfsequence_bi_unqie[transfer_rule]: "bi_unique cr_vfsequence"
  unfolding cr_vfsequence_def bi_unique_def
  by (simp add: inj_eq inj_vfsequence_of_vlist)

lemma cr_vfsequence_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_vfsequence = (λxs. vfsequence xs)"
  unfolding cr_vfsequence_def
proof(intro HOL.ext, rule iffI)
  fix xs assume prems: "vfsequence xs"
  interpret vfsequence xs by (rule prems)
  have "∃ys. xs = vfsequence_of_vlist ys"
    using prems
  proof(induction rule: vfsequence_induct)
    show "⟦ vfsequence xs; ∃ys. xs = vfsequence_of_vlist ys ⟧ ⟹
      ∃ys. xs #∘ x = vfsequence_of_vlist ys"
      for xs x
      unfolding vfsequence_of_vlist_def by (metis list.simps(7))
  qed auto 
  then show "Domainp (λa b. a = vfsequence_of_vlist b) xs" by auto
qed (clarsimp simp: vfsequence_vfsequence_of_vlist)

lemma cr_vfsequence_vconsD:
  assumes "cr_vfsequence (xs #∘ x) (y # ys)" 
  shows "cr_vfsequence xs ys" and "x = y"
proof-
  from assms[unfolded cr_vfsequence_def] have xs_x_def: 
    "xs #∘ x = vfsequence_of_vlist (y # ys)" .
  then have xs_x: "vfsequence (xs #∘ x)" 
    by (simp add: vfsequence_vfsequence_of_vlist)
  interpret vfsequence xs
    by (blast intro: vfsequence.vfsequence_vremove_vcons_vfsequence xs_x)
  from 
    assms[unfolded cr_vfsequence_def vfsequence_of_vlist.simps(2)]
    vfsequence_axioms 
  show "cr_vfsequence xs ys" and "x = y"
    unfolding cr_vfsequence_def by (auto simp: vfsequence_vfsequence_of_vlist)
qed


text‹Transfer relation 2.›

definition cr_cr_vfsequence :: "V ⇒ V list list ⇒ bool"
  where "cr_cr_vfsequence a b ⟷ 
    (a = vfsequence_of_vlist (map vfsequence_of_vlist b))"

lemma cr_cr_vfsequence_right_total[transfer_rule]: 
  "right_total cr_cr_vfsequence"
  unfolding cr_cr_vfsequence_def right_total_def by simp

lemma cr_cr_vfsequence_bi_unqie[transfer_rule]: "bi_unique cr_cr_vfsequence"
  unfolding cr_cr_vfsequence_def bi_unique_def
  by (simp add: inj_eq inj_vfsequence_of_vlist)


text‹Transfer relation for scalars.›

definition cr_scalar :: "(V ⇒ 'a ⇒ bool) ⇒ V ⇒ 'a ⇒ bool"
  where "cr_scalar R x y = (∃a. x = [a]∘ ∧ R a y)"

lemma cr_scalar_bi_unique[transfer_rule]:
  assumes "bi_unique R"
  shows "bi_unique (cr_scalar R)"
  using assms unfolding cr_scalar_def bi_unique_def by auto

lemma cr_scalar_right_total[transfer_rule]:
  assumes "right_total R"
  shows "right_total (cr_scalar R)"
  using assms unfolding cr_scalar_def right_total_def by simp

lemma cr_scalar_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp (cr_scalar R) = (λx. ∃a. x = [a]∘ ∧ Domainp R a)"
  unfolding cr_scalar_def by auto


subsubsection‹Transfer rules for previously defined entities›

context 
  includes lifting_syntax
begin

lemma vfsequence_vempty_transfer[transfer_rule]: "cr_vfsequence []∘ []"
  unfolding cr_vfsequence_def by simp

lemma vfsequence_vempty_ll_transfer[transfer_rule]: 
  "cr_cr_vfsequence [[]∘]∘ [[]]"
  unfolding cr_cr_vfsequence_def by simp

lemma vcons_transfer[transfer_rule]:
  "((=) ===> cr_vfsequence ===> cr_vfsequence) (λx xs. xs #∘ x) (λx xs. x # xs)"
  by (intro rel_funI) (simp add: cr_vfsequence_def)

lemma vcons_ll_transfer[transfer_rule]:
  "(cr_vfsequence ===> cr_cr_vfsequence ===> cr_cr_vfsequence) 
    (λx xs. xs #∘ x) (λx xs. x # xs)"
  by (intro rel_funI) (simp add: cr_vfsequence_def cr_cr_vfsequence_def)

lemma vfsequence_vrange_transfer[transfer_rule]:
  "(cr_vfsequence ===> (=)) (λxs. elts (ℛ∘ xs)) list.set"
proof(intro rel_funI)
  fix xs ys assume prems: "cr_vfsequence xs ys"
  then have "xs = vfsequence_of_vlist ys" unfolding cr_vfsequence_def by simp
  then have "vfsequence xs" by (simp add: vfsequence_vfsequence_of_vlist)
  from this prems show "elts (ℛ∘ xs) = list.set ys"
  proof(induction ys arbitrary: xs)
    case (Cons a ys)
    from Cons(2) show ?case 
    proof(cases xs rule: vfsequence_cases)
      case 0 with Cons show ?thesis by (simp add: Cons.IH cr_vfsequence_def)
    next
      case (vcons xs' x)
      interpret vfsequence xs' by (rule vcons(2))
      note vcons_transfer = cr_vfsequence_vconsD[OF Cons(3)[unfolded vcons(1)]]
      have a_ys: "list.set (a # ys) = insert a (list.set ys)" by simp
      from vcons(2) have R_xs'x: "ℛ∘ (xs' #∘ x) = vinsert x (ℛ∘ xs')" by simp
      show "elts (ℛ∘ xs) = (list.set (a # ys))"
        unfolding vcons(1) R_xs'x a_ys
        by 
          (
            auto simp: 
              vcons_transfer(2) Cons(1)[OF vfsequence_axioms vcons_transfer(1)]
          )
    qed
  qed (auto simp: cr_vfsequence_def)
qed

lemma vcard_transfer[transfer_rule]: 
  "(cr_vfsequence ===> cr_omega) vcard length"
proof(intro rel_funI)
  fix xs ys assume prems: "cr_vfsequence xs ys"
  then have "xs = vfsequence_of_vlist ys" unfolding cr_vfsequence_def by simp
  then have "vfsequence xs" by (simp add: vfsequence_vfsequence_of_vlist)
  from this prems show "cr_omega (vcard xs) (length ys)"
  proof(induction ys arbitrary: xs)
    case (Cons y ys)
    from Cons(2) show ?case 
    proof(cases xs rule: vfsequence_cases)
      case 0 with Cons show ?thesis by (simp add: Cons.IH cr_vfsequence_def)
    next
      case (vcons xs' x)
      interpret vfsequence xs' by (rule vcons(2))
      note vcons_transfer = cr_vfsequence_vconsD[OF Cons(3)[unfolded vcons(1)]]
      have vcard_xs_x: "vcard (xs' #∘ x) = succ (vcard xs')" by simp
      have vcard_y_ys: "length (y # ys) = Suc (length ys)" by simp
      from vfsequence_axioms have [transfer_rule]: 
        "cr_omega (vcard xs') (length ys)"
        by (simp add: vcons_transfer(1) Cons.IH)
      show ?thesis unfolding vcons(1) vcard_xs_x vcard_y_ys by transfer_prover
    qed
  qed (auto simp: cr_omega_def cr_vfsequence_def)
qed

lemma vcard_ll_transfer[transfer_rule]: 
  "(cr_cr_vfsequence ===> cr_omega) vcard length"
  unfolding cr_cr_vfsequence_def
  by (intro rel_funI)
    (metis cr_vfsequence_def length_map rel_funD vcard_transfer)

end


text‹Corollaries.›

lemma vrange_vfsequence_of_vlist: 
  "ℛ∘ (vfsequence_of_vlist xs) = set (list.set xs)"
proof(intro vsubset_antisym vsubsetI)
  fix x assume prems: "x ∈∘ ℛ∘ (vfsequence_of_vlist xs)" 
  define ys where "ys = vfsequence_of_vlist xs"
  have [transfer_rule]: "cr_vfsequence ys xs" "x = x" 
    unfolding ys_def cr_vfsequence_def by simp_all
  show "x ∈∘ set (list.set xs)" by transfer (simp add: prems[folded ys_def])
next
  fix x assume prems: "x ∈∘ set (list.set xs)"
  define ys where "ys = vfsequence_of_vlist xs"
  have [transfer_rule]: "cr_vfsequence ys xs" "x = x" 
    unfolding ys_def cr_vfsequence_def by simp_all
  from prems[untransferred] show "x ∈∘ ℛ∘ (vfsequence_of_vlist xs)"
    unfolding ys_def by simp
qed

lemma cr_cr_vfsequence_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_cr_vfsequence = 
    (λxss. vfsequence xss ∧ (∀xs∈∘ℛ∘ xss. vfsequence xs))"
proof(intro HOL.ext, rule iffI; (elim conjE | intro conjI ballI))
  fix xss assume prems: "Domainp cr_cr_vfsequence xss"
  with vfsequence_vfsequence_of_vlist show xss: "vfsequence xss"
    unfolding cr_cr_vfsequence_def by clarsimp
  interpret vfsequence xss by (rule xss)
  fix xs assume prems': "xs ∈∘ ℛ∘ xss"
  from prems obtain yss where xss_def: 
    "xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
    unfolding cr_cr_vfsequence_def by clarsimp
  from prems' have "xs ∈∘ set (list.set (map vfsequence_of_vlist yss))"
    unfolding xss_def vrange_vfsequence_of_vlist by simp
  then obtain ys where xs_def: "xs = vfsequence_of_vlist ys" by clarsimp
  show "vfsequence xs"
    unfolding xs_def by (simp add: vfsequence_vfsequence_of_vlist)
next
  fix xss assume prems: "vfsequence xss" "∀xs∈∘ℛ∘ xss. vfsequence xs"
  have "∃yss. xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
    using prems
  proof(induction rule: vfsequence_induct)
    case (vcons xss x)
    let ?y = ‹vlist_of_vfsequence x›
    from vcons(2,3) obtain yss where xss_def: 
      "xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
      by auto
    from vcons(3) have "vfsequence x" by auto
    then have x_def: "x = vfsequence_of_vlist (vlist_of_vfsequence x)" by simp
    then have 
      "xss #∘ x = vfsequence_of_vlist (map vfsequence_of_vlist (?y # yss))"
      unfolding xss_def by simp
    then show ?case by blast
  qed (auto intro: exI[of _ ‹[]›])
  then show "Domainp cr_cr_vfsequence xss" 
    unfolding cr_cr_vfsequence_def by blast
qed


subsubsection‹Appending elements›

definition vappend :: "V ⇒ V ⇒ V" (infixr "@∘" 65)
  where "xs @∘ ys =
    vfsequence_of_vlist (vlist_of_vfsequence ys @ vlist_of_vfsequence xs)"


text‹Transfer.›

lemma vappend_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vfsequence ===> cr_vfsequence ===> cr_vfsequence) 
    (λxs ys. vappend ys xs) append"
  by (intro rel_funI, unfold cr_vfsequence_def) (simp add: vappend_def)

lemma vappend_ll_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_cr_vfsequence ===> cr_cr_vfsequence ===> cr_cr_vfsequence) 
    (λxs ys. vappend ys xs) append"
  by (intro rel_funI, unfold cr_cr_vfsequence_def) (simp add: vappend_def)


text‹Elementary properties.›

lemma (in vfsequence) vfsequence_vappend_vempty_vfsequence[simp]: 
  "[]∘ @∘ xs = xs"
  unfolding vappend_def by auto

lemmas vfsequence_vappend_vempty_vfsequence[simp] =
  vfsequence.vfsequence_vappend_vempty_vfsequence

lemma (in vfsequence) vfsequence_vappend_vfsequence_vempty[simp]:
  "xs @∘ []∘ = xs"
  unfolding vappend_def by auto

lemmas vfsequence_vappend_vfsequence_vempty[simp] =
  vfsequence.vfsequence_vappend_vfsequence_vempty

lemma vappend_vcons[simp]: 
  assumes "vfsequence xs" and "vfsequence ys"
  shows "xs @∘ (ys #∘ y) = (xs @∘ ys) #∘ y"
  using append_Cons[where 'a=V, untransferred, OF assms(2,1)] by simp


subsubsection‹Distinct elements›

definition vdistinct :: "V ⇒ bool"
  where "vdistinct xs = distinct (vlist_of_vfsequence xs)"


text‹Transfer.›

lemma vdistinct_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vfsequence ===> (=)) vdistinct distinct"
  by (intro rel_funI, unfold cr_vfsequence_def) (simp add: vdistinct_def)

lemma vdistinct_ll_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_cr_vfsequence ===> (=)) vdistinct distinct" 
  by (intro rel_funI, unfold cr_cr_vfsequence_def)
    (
      metis 
        vdistinct_def 
        distinct_map 
        inj_onI 
        vlist_of_vfsequence_vfsequence_of_vlist
    )


text‹Elementary properties.›

lemma (in vfsequence) vfsequence_vdistinct_if_vcard_vrange_eq_vcard:
  assumes "vcard (ℛ∘ xs) = vcard xs"
  shows "vdistinct xs"
proof-
  have "finite (elts (ℛ∘ xs))" by (simp add: assms vcard_vfinite_omega)
  from vcard_finite_set[OF this] assms have "card (elts (ℛ∘ xs))ℕ = vcard xs"
    by simp
  from card_distinct[where ?'a=V, untransferred, OF vfsequence_axioms this] 
  show ?thesis.
qed

lemma vdistinct_vempty[intro, simp]: "vdistinct []∘"
proof-
  have t: "distinct ([]::V list)" by simp
  show ?thesis by (rule t[untransferred])
qed

lemma (in vfsequence) vfsequence_vcons_vdistinct:
  assumes "vdistinct (xs #∘ x)" 
  shows "vdistinct xs"
proof-
  from distinct.simps(2)[where 'a=V, THEN iffD1, THEN conjunct2, untransferred]
  show ?thesis
    using vfsequence_axioms assms by simp
qed

lemma (in vfsequence) vfsequence_vcons_nin_vrange:
  assumes "vdistinct (xs #∘ x)" 
  shows "x ∉∘ ℛ∘ xs"
proof-
  from distinct.simps(2)[where 'a=V, THEN iffD1, THEN conjunct1, untransferred]
  show ?thesis
    using vfsequence_axioms assms by simp
qed

lemma (in vfsequence) vfsequence_v11I[intro]:
  assumes "vdistinct xs"
  shows "v11 xs"
  using vfsequence_axioms assms
proof(induction xs rule: vfsequence_induct)
  case (vcons xs x)
  interpret vfsequence xs by (rule vcons(1))
  from vcons(3) have dxs: "vdistinct xs" by (rule vfsequence_vcons_vdistinct)
  interpret v11 xs using dxs by (rule vcons(2))
  from vfsequence_vcons_nin_vrange[OF vcons(3)] have "x ∉∘ ℛ∘ xs" .
  show "v11 (xs #∘ x)"
    by  
      ( 
        simp_all add: 
          vcons_def vfsequence_vdomain vfsequence_vcons_nin_vrange[OF vcons(3)]
      )
qed simp

lemma (in vfsequence) vfsequence_vcons_vdistinctI:
  assumes "vdistinct xs" and "x ∉∘ ℛ∘ xs"
  shows "vdistinct (xs #∘ x)"
proof-
  have t: "distinct xs ⟹ x ∉ list.set xs ⟹ distinct (x # xs)" 
    for x ::V and xs 
    by simp
  from vfsequence_axioms assms show ?thesis by (rule t[untransferred])
qed

lemmas vfsequence_vcons_vdistinctI[intro] =
  vfsequence.vfsequence_vcons_vdistinctI 

lemma (in vfsequence) vfsequence_nin_vrange_vcons:
  assumes "y ∉∘ ℛ∘ xs" and "y ≠ x"
  shows "y ∉∘ ℛ∘ (xs #∘ x)"
proof-
  have t: "y ∉ list.set xs ⟹ y ≠ x ⟹ y ∉ list.set (x # xs)" 
    for x y :: V and xs
    by simp
  from vfsequence_axioms assms show ?thesis by (rule t[untransferred])
qed

lemmas vfsequence_nin_vrange_vcons[intro] = 
  vfsequence.vfsequence_nin_vrange_vcons


subsubsection‹Concatenation of sequences›

definition vconcat :: "V ⇒ V"
  where "vconcat xss =
    vfsequence_of_vlist(
      concat (map vlist_of_vfsequence (vlist_of_vfsequence xss))
    )"


text‹Transfer.›

lemma vconcat_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_cr_vfsequence ===> cr_vfsequence) vconcat concat"
proof(intro rel_funI)
  fix xs ys assume "cr_cr_vfsequence xs ys"
  then have xs_def: "xs = vfsequence_of_vlist (map vfsequence_of_vlist ys)"
    unfolding cr_cr_vfsequence_def by simp
  have main_eq: "map vlist_of_vfsequence (vlist_of_vfsequence xs) = ys"
    unfolding xs_def by (simp add: map_idI)
  show "cr_vfsequence (vconcat xs) (concat ys)"
    unfolding cr_vfsequence_def vconcat_def main_eq ..
qed


text‹Elementary properties.›

lemma vconcat_vempty[simp]: "vconcat []∘ = []∘"
  unfolding vconcat_def by simp

lemma vconcat_append[simp]: 
  assumes "vfsequence xss" 
    and "∀xs∈∘ℛ∘ xss. vfsequence xs" 
    and "vfsequence yss"
    and "∀xs∈∘ℛ∘ yss. vfsequence xs" 
  shows "vconcat (xss @∘ yss) = vconcat xss @∘ vconcat yss"
  using assms concat_append[where 'a=V, untransferred] by simp

lemma vconcat_vcons[simp]: 
  assumes "vfsequence xs" and "vfsequence xss" and "∀xs∈∘ℛ∘ xss. vfsequence xs"
  shows "vconcat (xss #∘ xs) = vconcat xss @∘ xs"
  using assms concat.simps(2)[where 'a=V, untransferred] by simp

lemma (in vfsequence) vfsequence_vconcat_fsingleton[simp]: "vconcat [xs]∘ = xs"
  using vfsequence_axioms 
  by 
    (
      metis 
        vfsequence_vappend_vempty_vfsequence 
        vconcat_vcons 
        vconcat_vempty 
        vempty_nin 
        vfsequence_vempty 
        vrange_vempty
    )

lemmas vfsequence_vconcat_fsingleton[simp] = 
  vfsequence.vfsequence_vconcat_fsingleton



subsection‹Finite sequences and the Cartesian product›

lemma vfsequence_vcons_vproductI[intro!]:
  assumes "n ∈∘ ω" 
    and "xs ∈∘ (∏∘i∈∘vcard xs. A i)" 
    and "x ∈∘ A (vcard xs)" 
    and "n = vcard (xs #∘ x)"
  shows "xs #∘ x ∈∘ (∏∘i∈∘n. A i)"
proof
  interpret xs: vfsequence xs 
    using assms
    apply(intro vfsequenceI)
    subgoal by auto
    subgoal
      by 
        (
          metis 
            vcard_vfinite_omega 
            vcons_vsubset 
            vfinite_vcard_omega 
            vfinite_vsubset vproductD(2)
        )
    done
  interpret xsx: vfsequence ‹xs #∘ x› by auto
  show "vsv (xs #∘ x)" by (simp add: xsx.vsv_axioms)
  show D: "𝒟∘ (xs #∘ x) = n" unfolding assms(4) xsx.vfsequence_vdomain by auto
  from vproductD[OF assms(2)] have elem: "i ∈∘ vcard xs ⟹ xs⦇i⦈ ∈∘ A i" for i
    by auto
  show "∀i∈∘n. (xs #∘ x)⦇i⦈ ∈∘ A i" by (auto simp: elem assms(3,4))
qed

lemma vfsequence_vcons_vproductD[dest]:
  assumes "xs #∘ x ∈∘ (∏∘i∈∘n. A i)" and "n ∈∘ ω"
  shows "xs ∈∘ (∏∘i∈∘vcard xs. A i)" 
    and "x ∈∘ A (vcard xs)" 
    and "n = vcard (xs #∘ x)" 
proof-

  interpret xsx: vfsequence ‹xs #∘ x› 
    by (meson assms succ_in_omega vfsequence_vproduct)
  interpret xs: vfsequence xs
    by (blast intro: xsx.vfsequence_vremove_vcons_vfsequence)

  show n_def: "n = vcard (xs #∘ x)"
    using assms using xsx.vfsequence_vdomain by blast
  from vproductD[OF assms(1), unfolded n_def] 
  have elem_xs_x: "i ∈∘ vcard (xs #∘ x) ⟹ (xs #∘ x)⦇i⦈ ∈∘ A i" 
    for i
    by auto
  then have elem_xs[simp]: "i ∈∘ vcard xs ⟹ xs⦇i⦈ ∈∘ A i" for i
    by (metis rev_vsubsetD vcard_mono vcons_vsubset xs.vfsequence_at_not_last)
  show "xs ∈∘ (∏∘i∈∘vcard xs. A i)"
    by (auto simp: xs.vsv_axioms xs.vfsequence_vdomain)
  from elem_xs_x show "x ∈∘ A (vcard xs)" by fastforce

qed

lemma vfsequence_vcons_vproductE[elim!]:
  assumes "xs #∘ x ∈∘ (∏∘i∈∘n. A i)" and "n ∈∘ ω"
  obtains "xs ∈∘ (∏∘i∈∘vcard xs. A i)" 
    and "x ∈∘ A (vcard xs)" 
    and "n = vcard (xs #∘ x)" 
  using assms by (auto simp: vfsequence_vcons_vproductD)



subsection‹Binary Cartesian product based on finite sequences: ‹ftimes››

definition ftimes :: "V ⇒ V ⇒ V" (infixr ‹×∙› 80)
  where "ftimes a b ≡ (∏∘i∈∘2ℕ. if i = 0 then a else b)"

lemma small_fpairs[simp]: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ r}"
  by (rule down[of _ r]) clarsimp


text‹Rules.›

lemma ftimesI1[intro]: 
  assumes "x = [a, b]∘" and "a ∈∘ A" and "b ∈∘ B"
  shows "x ∈∘ A ×∙ B"
  unfolding ftimes_def
proof
  show vsv: "vsv x" by (simp add: assms(1) vfsequence.axioms(1))
  then interpret vsv x .
  from assms show D: "𝒟∘ x = 2ℕ" 
    unfolding nat_omega_simps two One_nat_def by auto
  from assms(2,3) have i: "i ∈∘ 2ℕ ⟹ x⦇i⦈ ∈∘ (if i = 0ℕ then A else B)" 
    for i
    unfolding assms(1) two nat_omega_simps One_nat_def by auto
  from i show "∀i∈∘2ℕ. x⦇i⦈ ∈∘ (if i = 0 then A else B)" by auto
qed

lemma ftimesI2[intro!]: 
  assumes "a ∈∘ A" and "b ∈∘ B"
  shows "[a, b]∘ ∈∘ A ×∙ B"
  using assms ftimesI1 by auto

lemma fproductE1[elim!]:
  assumes "x ∈∘ A ×∙ B"
  obtains a b where "x = [a, b]∘" and "a ∈∘ A" and "b ∈∘ B"
proof-
  from vproduct_vdoubletonD[OF assms[unfolded two ftimes_def]] 
  have x_def: "x = set {⟨0ℕ, x⦇0ℕ⦈⟩, ⟨1ℕ, x⦇1ℕ⦈⟩}"
    and "x⦇0ℕ⦈ ∈∘ A" 
    and "x⦇1ℕ⦈ ∈∘ B" 
    by auto
  then show ?thesis using that using vcons_vdoubleton by simp
qed

lemma fproductE2[elim!]:
  assumes "[a, b]∘ ∈∘ A ×∙ B" obtains "a ∈∘ A" and "b ∈∘ B"
  using assms by blast


text‹Set operations.›

lemma vfinite_0_left[simp]: "0 ×∙ b = 0"
  by (meson eq0_iff fproductE1)

lemma vfinite_0_right[simp]: "a ×∙ 0 = 0"
  by (meson eq0_iff fproductE1)

lemma fproduct_vintersection: "(a ∩∘ b) ×∙ (c ∩∘ d) = (a ×∙ c) ∩∘ (b ×∙ d)"
  by auto

lemma fproduct_vdiff: "a ×∙ (b -∘ c) = (a ×∙ b) -∘ (a ×∙ c)" by auto

lemma vfinite_ftimesI[intro!]:
  assumes "vfinite a" and "vfinite b"
  shows "vfinite (a ×∙ b)"
  using assms(1,2) 
proof(induction arbitrary: b rule: vfinite_induct)
  case (vinsert x a')
  from vinsert(4) have "vfinite (set {x} ×∙ b)"
  proof(induction rule: vfinite_induct)
    case (vinsert y b')
    have "set {x} ×∙ vinsert y b' = vinsert [x, y]∘ (set {x} ×∙ b')" by auto
    with vinsert(3) show ?case by simp
  qed simp
  moreover have "vinsert x a' ×∙ b = (set {x} ×∙ b) ∪∘ (a' ×∙ b)" by auto
  ultimately show ?case using vinsert by (auto simp: vfinite_vunionI)
qed simp


text‹‹ftimes› and ‹vcpower››

lemma vproduct_vpair: "[a, b]∘ ∈∘ (∏∘i∈∘2ℕ. f i) ⟷ ⟨a, b⟩ ∈∘ f (0ℕ) ×∘ f (1ℕ)"
proof
  interpret vfsequence ‹[a, b]∘› by simp
  show "[a, b]∘ ∈∘ (∏∘i∈∘2ℕ. f i) ⟹ ⟨a, b⟩ ∈∘ f (0ℕ) ×∘ f (1ℕ)"
    unfolding vcons_vdoubleton two by (elim vproduct_vdoubletonE) auto
  assume hyp: "⟨a, b⟩ ∈∘ f (0ℕ) ×∘ f (1ℕ)" 
  then have af: "a ∈∘ f (0ℕ)" and bf: "b ∈∘ f (1ℕ)" by auto
  have dom: "𝒟∘ [a, b]∘ = set {0ℕ, 1ℕ}" by (auto intro!: vsubset_antisym)
  have ran: "ℛ∘ [a, b]∘ ⊆∘ (⋃∘i∈∘2ℕ. f i)"
    unfolding two using af bf vifunion_vdoubleton by auto  
  show "[a, b]∘ ∈∘ (∏∘i∈∘2ℕ. f i)"
    apply(intro vproductI)
    subgoal using dom ran vsv_axioms unfolding two by auto
    subgoal using af bf unfolding two by (auto intro!: vsubset_antisym)
    subgoal 
      unfolding two 
      using hyp VSigmaE2 small_empty vcons_vdoubleton 
      by (auto simp: vinsert_set_insert_eq)
    done
qed


text‹Connections.›

lemma vcpower_two_ftimes: "A ^× 2ℕ = A ×∙ A" 
  unfolding vcpower_def ftimes_def two by simp

lemma vcpower_two_ftimesI[intro]: 
  assumes "x ∈∘ A ×∙ A"
  shows "x ∈∘ A ^× 2ℕ"
  using assms unfolding ftimes_def two by auto

lemma vcpower_two_ftimesD[dest]:
  assumes "x ∈∘ A ^× 2ℕ"
  shows "x ∈∘ A ×∙ A"
  using assms unfolding vcpower_def ftimes_def two by simp

lemma vcpower_two_ftimesE[elim]:
  assumes "x ∈∘ A ^× 2ℕ" and "x ∈∘ A ×∙ A ⟹ P"
  shows P
  using assms unfolding vcpower_def ftimes_def two by simp

lemma vfsequence_vcpower_two_vpair: "[a, b]∘ ∈∘ A ^× 2ℕ ⟷ ⟨a, b⟩ ∈∘ A ×∘ A"
proof(rule iffI)
  show "[a, b]∘ ∈∘ A ^× 2ℕ ⟹ ⟨a, b⟩ ∈∘ A ×∘ A"
    by (elim vcpowerE, unfold vproduct_vpair) 
qed (intro vcpowerI, unfold vproduct_vpair)

lemma vsv_vfsequence_two: 
  assumes "vsv gf" and "𝒟∘ gf = 2ℕ"
  shows "[vpfst gf, vpsnd gf]∘ = gf"
proof-
  interpret gf: vsv gf by (auto intro: assms(1))
  show ?thesis
    by
      (
        rule sym,
        rule vsv_eqI, 
        blast, 
        blast, 
        simp add: assms(2) nat_omega_simps,
        unfold assms(2),
        elim_in_numeral,
        all‹simp add: nat_omega_simps›
      )
qed

lemma vsv_vfsequence_three: 
  assumes "vsv hgf" and "𝒟∘ hgf = 3ℕ"
  shows "[vpfst hgf, vpsnd hgf, vpthrd hgf]∘ = hgf"
proof-
  interpret hgf: vsv hgf by (auto intro: assms(1))
  show ?thesis
    by
      (
        rule sym,
        rule vsv_eqI, 
        blast, 
        blast, 
        simp add: assms(2) nat_omega_simps,
        unfold assms(2),
        elim_in_numeral,
        all‹simp add: nat_omega_simps›
      )
qed



subsection‹Sequence as an element of a Cartesian power of a set›

lemma vcons_in_vcpowerI[intro!]: 
  assumes "n ∈∘ ω" 
    and "xs ∈∘ A ^× vcard xs" 
    and "x ∈∘ A" 
    and "n = vcard (xs #∘ x)" 
  shows "xs #∘ x ∈∘ A ^× n"
proof-
  interpret vfsequence xs
    using assms
    by
      (
        meson 
          vcons_vsubset 
          vfinite_vcard_omega_iff 
          vfinite_vsubset 
          vfsequence_vcpower
      )
  show ?thesis 
    by 
      (
        metis 
          assms(2,3,4)
          vcpower_vrange 
          vfsequence_vcons 
          vfsequence_vcons_vrange 
          vfsequence.vfsequence_vrange_vcpower 
          vsubset_vinsert_leftI
      )
qed

lemma vcons_in_vcpowerD[dest]: 
  assumes "xs #∘ x ∈∘ A ^× n" and "n ∈∘ ω"
  shows "xs ∈∘ A ^× vcard xs" 
    and "x ∈∘ A" 
    and "n = vcard (xs #∘ x)" 
proof-
  interpret vfsequence xs 
    by 
      (
        meson 
          assms 
          vfsequence.vfsequence_vremove_vcons_vfsequence 
          vfsequence_vcpower
      )
  from assms vfsequence_vcard_vcons show "n = vcard (xs #∘ x)" by auto
  then show "xs ∈∘ A ^× vcard xs" 
    by 
      (
        metis 
          assms(1) 
          vcpower_vrange 
          vfsequence_vcons_vrange 
          vfsequence_vrange_vcpower 
          vsubset_vinsert_leftD
      )
  show "x ∈∘ A"
    by 
      (
        metis 
          assms(1) 
          vcpower_vrange 
          vfsequence.vfsequence_vcons_vrange 
          vfsequence_axioms 
          vinsertI1 
          vsubsetE
      )
qed

lemma vcons_in_vcpowerE1[elim!]: 
  assumes "xs #∘ x ∈∘ A ^× n" and "n ∈∘ ω"
  obtains "xs ∈∘ A ^× vcard xs" and "x ∈∘ A" and "n = vcard (xs #∘ x)" 
  using assms by blast

lemma vcons_in_vcpowerE2: 
  assumes "xs ∈∘ A ^× n" and "n ∈∘ ω" and "0 ∈∘ n"
  obtains x xs' where "xs = xs' #∘ x"
    and "xs' ∈∘ A ^× vcard xs'" 
    and "x ∈∘ A" 
    and "n = vcard (xs' #∘ x)" 
proof-
  interpret vfsequence xs using assms(1,2) by auto
  from assms obtain x xs' where xs_def: "xs = xs' #∘ x"
    by 
      (
        metis 
          eq0_iff vcard_0 vcpower_vdomain vfsequence_vcons_ex vfsequence_vdomain
      )
  from vcons_in_vcpowerE1[OF assms(1)[unfolded xs_def] assms(2)] have
    "xs' ∈∘ A ^× vcard xs'" and "x ∈∘ A" and "n = vcard (xs' #∘ x)" 
    by blast+
  from xs_def this show ?thesis by (clarsimp simp: that)
qed

lemma vcons_vcpower1E: (*TODO: generalize*)
  assumes "xs ∈∘ A ^× 1ℕ"  
  obtains x where "xs = [x]∘" and "x ∈∘ A"
proof-
  have 01: "0 ∈∘ 1ℕ" by simp
  from vcons_in_vcpowerE2[OF assms ord_of_nat_ω 01] obtain x xs' 
    where xs_def: "xs = xs' #∘ x"
      and xs': "xs' ∈∘ A ^× vcard xs'" 
      and x: "x ∈∘ A" 
      and one: "1ℕ = vcard (xs' #∘ x)" 
    by metis
  interpret xs: vfsequence xs using assms by (auto intro: vfsequence_vcpower)
  interpret xs': vfsequence xs' 
    using xs' xs_def xs.vfsequence_vremove_vcons_vfsequence by blast
  from one have "vcard xs' = 0" 
    by (metis ord_of_nat_succ_vempty succ_inject_iff xs'.vfsequence_vcard_vcons)
  then have "xs = [x]∘" unfolding xs_def by (simp add: vcard_vempty)
  with x that show ?thesis by simp
qed

text‹\newpage›

end

Theory CZH_Sets_FBRelations

(* Copyright 2021 (C) Mihails Milehins *)

section‹Binary relation as a finite sequence›
theory CZH_Sets_FBRelations
  imports CZH_Sets_FSequences
begin



subsection‹Background›


text‹
This section exposes the theory of binary relations that are represented by
a two element finite sequence ‹[a, b]∘› (as opposed to a pair ‹⟨a, b⟩›).
Many results were adapted from the theory ‹CZH_Sets_BRelations›. 

As previously, many of the results that are presented in this 
section can be assumed to have been adapted (with amendments) from the 
theory text‹Relation› in the main library.
›

lemma fpair_iff[simp]: "([a, b]∘ = [a', b']∘) = (a = a' ∧ b = b')" by simp

lemmas fpair_inject[elim!] = fpair_iff[THEN iffD1, THEN conjE]



subsection‹‹fpairs››

definition fpairs :: "V ⇒ V" where
  "fpairs r = set {x. x ∈∘ r ∧ (∃a b. x = [a, b]∘)}"

lemma small_fpairs[simp]: "small {x. x ∈∘ r ∧ (∃a b. x = [a, b]∘)}"
  by (rule down[of _ r]) clarsimp


text‹Rules.›

lemma fpairsI[intro]: 
  assumes "x ∈∘ r" and "x = [a, b]∘" 
  shows "x ∈∘ fpairs r"
  using assms unfolding fpairs_def by auto

lemma fpairsD[dest]:
  assumes "x ∈∘ fpairs r" 
  shows "x ∈∘ r" and "∃a b. x = [a, b]∘" 
  using assms unfolding fpairs_def by auto

lemma fpairsE[elim]:
  assumes "x ∈∘ fpairs r"
  obtains a b where "x = [a, b]∘" and "[a, b]∘ ∈∘ r"
  using assms unfolding fpairs_def by auto

lemma fpairs_iff: "x ∈∘ fpairs r ⟷ x ∈∘ r ∧ (∃a b. x = [a, b]∘)" by auto


text‹Elementary properties.›

lemma fpairs_iff_elts: "[a, b]∘ ∈∘ fpairs r ⟷ [a, b]∘ ∈∘ r" by auto


text‹Set operations.›

lemma fpairs_vempty[simp]: "fpairs 0 = 0" by auto

lemma fpairs_vsingleton[simp]: "fpairs (set {[a, b]∘}) = set {[a, b]∘}" by auto

lemma fpairs_vinsert: "fpairs (vinsert [a, b]∘ A) = set {[a, b]∘} ∪∘ fpairs A" 
  by auto

lemma fpairs_mono:
  assumes "r ⊆∘ s"
  shows "fpairs r ⊆∘ fpairs s"
  using assms by blast

lemma fpairs_vunion: "fpairs (A ∪∘ B) = fpairs A ∪∘ fpairs B" by auto

lemma fpairs_vintersection: "fpairs (A ∩∘ B) = fpairs A ∩∘ fpairs B" by auto

lemma fpairs_vdiff: "fpairs (A -∘ B) = fpairs A -∘ fpairs B" by auto


text‹Special properties.›

lemma fpairs_ex_vfst:
  assumes "x ∈∘ fpairs r"
  shows "∃b. [x⦇0ℕ⦈, b]∘ ∈∘ r"
proof-
  from assms have xr: "x ∈∘ r" by auto
  moreover from assms obtain b where x_def: "x = [x⦇0ℕ⦈, b]∘" by auto
  ultimately have "[x⦇0ℕ⦈, b]∘ ∈∘ r" by auto
  then show ?thesis by auto
qed

lemma fpairs_ex_vsnd:
  assumes "x ∈∘ fpairs r"
  shows "∃a. [a, x⦇1ℕ⦈]∘ ∈∘ r"
proof-
  from assms have xr: "x ∈∘ r" by auto
  moreover from assms obtain a where x_def: "x = [a, x⦇1ℕ⦈]∘" 
    by (auto simp: nat_omega_simps)
  ultimately have "[a, x⦇1ℕ⦈]∘ ∈∘ r" by auto
  then show ?thesis by auto
qed

lemma fpair_vcpower2I[intro]:
  assumes "a ∈∘ A ^× 1ℕ" and "b ∈∘ A ^× 1ℕ"
  shows "vconcat [a, b]∘ ∈∘ A ^× 2ℕ"
proof-
  from assms obtain a' b' 
    where a_def: "a = [a']∘" and b_def: "b = [b']∘" and "a'∈∘ A" and "b'∈∘ A"
    by (force elim: vcons_vcpower1E)
  then show ?thesis by (auto simp: nat_omega_simps)
qed



subsection‹Constructors›


subsubsection‹Identity relation›

definition fid_on :: "V ⇒ V"
  where "fid_on A = set {[a, a]∘ | a. a ∈∘ A}"

lemma fid_on_small[simp]: "small {[a, a]∘ | a. a ∈∘ A}"
proof(rule down[of _ ‹A ^× (2ℕ)›], intro subsetI)  
  fix x assume "x ∈ {[a, a]∘ |a. a ∈∘ A}"
  then obtain a where x_def: "x = [a, a]∘" and "a ∈∘ A" by clarsimp
  interpret vfsequence ‹[a, a]∘› by simp
  have vcard_aa: "2ℕ = vcard [a, a]∘" by (simp add: nat_omega_simps)
  from ‹a ∈∘ A› show "x ∈∘ A ^× 2ℕ"
    unfolding x_def vcard_aa by (intro vfsequence_vrange_vcpower) auto
qed


text‹Rules.›

lemma fid_on_eqI: 
  assumes "a = b" and "a ∈∘ A"
  shows "[a, b]∘ ∈∘ fid_on A"
  using assms by (simp add: fid_on_def)

lemma fid_onI[intro!]: 
  assumes "a ∈∘ A"
  shows "[a, a]∘ ∈∘ fid_on A"
  by (rule fid_on_eqI) (simp_all add: assms)

lemma fid_onD[dest!]: 
  assumes "[a, a]∘ ∈∘ fid_on A"
  shows "a ∈∘ A"
  using assms unfolding fid_on_def by auto

lemma fid_onE[elim!]: 
  assumes "x ∈∘ fid_on A" and "∃a∈∘A. x = [a, a]∘ ⟹ P" 
  shows P
  using assms unfolding fid_on_def by auto

lemma fid_on_iff: "[a, b]∘ ∈∘ fid_on A ⟷ a = b ∧ a ∈∘ A" by auto


text‹Set operations.›

lemma fid_on_vempty[simp]: "fid_on 0 = 0" by auto

lemma fid_on_vsingleton[simp]: "fid_on (set {a}) = set {[a, a]∘}" by auto

lemma fid_on_vdoubleton: "fid_on (set {a, b}) = set {[a, a]∘, [b, b]∘}" by force

lemma fid_on_mono: 
  assumes "A ⊆∘ B" 
  shows "fid_on A ⊆∘ fid_on B"
  using assms by auto

lemma fid_on_vinsert: "vinsert [a, a]∘ (fid_on A) = fid_on (vinsert a A)" 
  by auto

lemma fid_on_vintersection: "fid_on (A ∩∘ B) = fid_on A ∩∘ fid_on B" by auto

lemma fid_on_vunion: "fid_on (A ∪∘ B) = fid_on A ∪∘ fid_on B" by auto

lemma fid_on_vdiff: "fid_on (A -∘ B) = fid_on A -∘ fid_on B" by auto


text‹Special properties.›

lemma fid_on_vsubset_vcpower: "fid_on A ⊆∘ A ^× 2ℕ" by force


subsubsection‹Constant function›

definition fconst_on :: "V ⇒ V ⇒ V"
  where "fconst_on A c = set {[a, c]∘ | a. a ∈∘ A}"

lemma small_fconst_on[simp]: "small {[a, c]∘ | a. a ∈∘ A}"
  by (rule down[of _ ‹A ×∙ set {c}›]) blast


text‹Rules.›

lemma fconst_onI[intro!]: 
  assumes "a ∈∘ A"
  shows "[a, c]∘ ∈∘ fconst_on A c"
  using assms unfolding fconst_on_def by simp

lemma fconst_onD[dest!]: 
  assumes "[a, c]∘ ∈∘ fconst_on A c"
  shows "a ∈∘ A" 
  using assms unfolding fconst_on_def by simp

lemma fconst_onE[elim!]: 
  assumes "x ∈∘ fconst_on A c"
  obtains a where "a ∈∘ A" and "x = [a, c]∘"
  using assms unfolding fconst_on_def by auto

lemma fconst_on_iff: "[a, c]∘ ∈∘ fconst_on A c ⟷ a ∈∘ A" by auto


text‹Set operations.›

lemma fconst_on_vempty[simp]: "fconst_on 0 c = 0"
  unfolding fconst_on_def by auto

lemma fconst_on_vsingleton[simp]: "fconst_on (set {a}) c = set {[a, c]∘}" 
  by auto

lemma fconst_on_vdoubleton: "fconst_on (set {a, b}) c = set {[a, c]∘, [b, c]∘}" 
  by force

lemma fconst_on_mono: 
  assumes "A ⊆∘ B" 
  shows "fconst_on A c ⊆∘ fconst_on B c"
  using assms by auto

lemma fconst_on_vinsert:
  "(vinsert [a, c]∘ (fconst_on A c)) = (fconst_on (vinsert a A) c)" 
  by auto

lemma fconst_on_vintersection: 
  "fconst_on (A ∩∘ B) c = fconst_on A c ∩∘ fconst_on B c"
  by auto

lemma fconst_on_vunion: "fconst_on (A ∪∘ B) c = fconst_on A c ∪∘ fconst_on B c"
  by auto

lemma fconst_on_vdiff: "fconst_on (A -∘ B) c = fconst_on A c -∘ fconst_on B c"
  by auto


text‹Special properties.›

lemma fconst_on_eq_ftimes: "fconst_on A c = A ×∙ set {c}" by blast


subsubsection‹Composition›

definition fcomp :: "V ⇒ V ⇒ V" (infixr ‹∘∙› 75)
  where "r ∘∙ s = set {[a, c]∘ | a c. ∃b. [a, b]∘ ∈∘ s ∧ [b, c]∘ ∈∘ r}"
notation fcomp (infixr "∘∙" 75)

lemma fcomp_small[simp]: "small {[a, c]∘ | a c. ∃b. [a, b]∘ ∈∘ s ∧ [b, c]∘ ∈∘ r}" 
  (is ‹small ?s›)
proof-
  define comp' where "comp' = (λ⟨ab, cd⟩. [ab⦇0ℕ⦈, cd⦇1ℕ⦈]∘)"
  have "small (elts (vpairs (s ×∘ r)))" by simp
  then have small_comp: "small (comp' ` elts (vpairs (s ×∘ r)))" by simp
  have ss: "?s ⊆ (comp' ` elts (vpairs (s ×∘ r)))" 
  proof
    fix x assume "x ∈ ?s"
    then obtain a b c where x_def: "x = [a, c]∘" 
      and "[a, b]∘ ∈∘ s" 
      and "[b, c]∘ ∈∘ r"
      by auto
    then have abbc: "⟨[a, b]∘, [b, c]∘⟩ ∈∘ vpairs (s ×∘ r)"
      by (simp add: vpairs_iff_elts)
    have x_def': "x = comp' ⟨[a, b]∘, [b, c]∘⟩" 
      unfolding comp'_def x_def by (auto simp: nat_omega_simps)
    then show "x ∈ comp' ` elts (vpairs (s ×∘ r))"
      unfolding x_def' using abbc by auto
  qed
  with small_comp show ?thesis by (meson smaller_than_small)
qed


text‹Rules.›

lemma fcompI[intro]: 
  assumes "[b, c]∘ ∈∘ r" and "[a, b]∘ ∈∘ s" 
  shows "[a, c]∘ ∈∘ r ∘∙ s"
  using assms unfolding fcomp_def by auto

lemma fcompD[dest]: 
  assumes "[a, c]∘ ∈∘ r ∘∙ s"
  shows "∃b. [b, c]∘ ∈∘ r ∧ [a, b]∘ ∈∘ s" 
  using assms unfolding fcomp_def by auto

lemma fcompE[elim]:
  assumes "ac ∈∘ r ∘∙ s" 
  obtains a b c where "ac = [a, c]∘" and "[a, b]∘ ∈∘ s" and "[b, c]∘ ∈∘ r"
  using assms unfolding fcomp_def by clarsimp


text‹Elementary properties.›

lemma fcomp_assoc: "(r ∘∙ s) ∘∙ t = r ∘∙ (s ∘∙ t)" by fast


text‹Set operations.›

lemma fcomp_vempty_left[simp]: "0 ∘∙ r = 0" unfolding vcomp_def by force

lemma fcomp_vempty_right[simp]: "r ∘∙ 0 = 0" unfolding vcomp_def by force

lemma fcomp_mono:
  assumes "r' ⊆∘ r" and "s' ⊆∘ s" 
  shows "r' ∘∙ s' ⊆∘ r ∘∙ s"
  using assms by force

lemma fcomp_vinsert_left[simp]: 
  "vinsert ([a, b]∘) s ∘∙ r = (set {[a, b]∘} ∘∙ r) ∪∘ (s ∘∙ r)" 
  by auto

lemma fcomp_vinsert_right[simp]: 
  "r ∘∙ vinsert [a, b]∘ s = (r ∘∙ set {[a, b]∘}) ∪∘ (r ∘∙ s)"
  by auto

lemma fcomp_vunion_left[simp]: "(s ∪∘ t) ∘∙ r = (s ∘∙ r) ∪∘ (t ∘∙ r)" by auto

lemma fcomp_vunion_right[simp]: "r ∘∙ (s ∪∘ t) = (r ∘∙ s) ∪∘ (r ∘∙ t)" by auto


text‹Connections.›

lemma fcomp_fid_on_idem[simp]: "fid_on A ∘∙ fid_on A = fid_on A" by auto

lemma fcomp_fid_on[simp]: "fid_on A ∘∙ fid_on B = fid_on (A ∩∘ B)" by auto

lemma fcomp_fconst_on_fid_on[simp]: "fconst_on A c ∘∙ fid_on A = fconst_on A c" 
  by auto


text‹Special properties.›

lemma fcomp_vsubset_vtimes:
  assumes "r ⊆∘ B ×∙ C" and "s ⊆∘ A ×∙ B" 
  shows "r ∘∙ s ⊆∘ A ×∙ C"
  using assms by blast

lemma fcomp_obtain_middle[elim]:
  assumes "[a, c]∘ ∈∘ f ∘∙ g"
  obtains b where "[a, b]∘ ∈∘ g" and "[b, c]∘ ∈∘ f"
  using assms by auto


subsubsection‹Converse relation›

definition fconverse :: "V ⇒ V" (‹(_¯∙)› [1000] 999)
  where "r¯∙ = set {[b, a]∘ | a b. [a, b]∘ ∈∘ r}"

lemma fconverse_small[simp]: "small {[b, a]∘ | a b. [a, b]∘ ∈∘ r}"
proof-
  have eq: 
    "{[b, a]∘ | a b. [a, b]∘ ∈∘ r} = (λx. [x⦇1ℕ⦈, x⦇0ℕ⦈]∘) ` elts (fpairs r)"
  proof(rule subset_antisym; rule subsetI, unfold mem_Collect_eq)
    fix x assume "x ∈ (λx. [x⦇1ℕ⦈, x⦇0ℕ⦈]∘) ` elts (fpairs r)" 
    then obtain a b where "[a, b]∘ ∈∘ fpairs r" 
      and "x = (λx. [x⦇1ℕ⦈, x⦇0ℕ⦈]∘) [a, b]∘"
      by blast
    then show "∃a b. x = [b, a]∘ ∧ [a, b]∘ ∈∘ r" by (auto simp: nat_omega_simps)
  qed (use image_iff fpairs_iff_elts in ‹fastforce simp: nat_omega_simps›)
  show ?thesis unfolding eq by (rule replacement) auto
qed


text‹Rules.›

lemma fconverseI[sym, intro!]: 
  assumes "[a, b]∘ ∈∘ r"
  shows "[b, a]∘ ∈∘ r¯∙"
  using assms unfolding fconverse_def by simp

lemma fconverseD[sym, dest]: 
  assumes "[a, b]∘ ∈∘ r¯∙"
  shows "[b, a]∘ ∈∘ r" 
  using assms unfolding fconverse_def by simp

lemma fconverseE[elim!]: 
  assumes "x ∈∘ r¯∙" 
  obtains a b where "x = [b, a]∘" and "[a, b]∘ ∈∘ r"
  using assms unfolding fconverse_def by auto

lemma fconverse_iff: "[b, a]∘ ∈∘ r¯∙ ⟷ [a, b]∘ ∈∘ r" by auto


text‹Set operations.›

lemma fconverse_vempty[simp]: "0¯∙ = 0" by auto

lemma fconverse_vsingleton: "(set {[a, b]∘})¯∙ = set {[b, a]∘}" by auto

lemma fconverse_vdoubleton: "(set {[a, b]∘, [c, d]∘})¯∙ = set {[b, a]∘, [d, c]∘}" 
  by force

lemma fconverse_vinsert: "(vinsert [a, b]∘ r)¯∙ = vinsert [b, a]∘ (r¯∙)" by auto

lemma fconverse_vintersection: "(r ∩∘ s)¯∙ = r¯∙ ∩∘ s¯∙" by auto

lemma fconverse_vunion: "(r ∪∘ s)¯∙ = r¯∙ ∪∘ s¯∙" by auto


text‹Connections.›

lemma fconverse_fid_on[simp]: "(fid_on A)¯∙ = fid_on A" by auto

lemma fconverse_fconst_on[simp]: "(fconst_on A c)¯∙ = set {c} ×∙ A" by blast

lemma fconverse_fcomp: "(r ∘∙ s)¯∙ = s¯∙ ∘∙ r¯∙" by auto

lemma fconverse_ftimes: "(A ×∙ B)¯∙ = (B ×∙ A)" by auto


text‹Special properties.›

lemma fconverse_pred:
  assumes "small {[a, b]∘ | a b. P a b}"
  shows "(set {[a, b]∘ | a b. P a b})¯∙ = set {[b, a]∘ | a b. P a b}"
  using assms unfolding fconverse_def by simp


subsubsection‹Left restriction›

definition flrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾l∙› 80)
  where "r ↾l∙ A = set {[a, b]∘ | a b. a ∈∘ A ∧ [a, b]∘ ∈∘ r}"

lemma flrestriction_small[simp]: "small {[a, b]∘ | a b. a ∈∘ A ∧ [a, b]∘ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma flrestrictionI[intro!]: 
  assumes "a ∈∘ A" and "[a, b]∘ ∈∘ r" 
  shows "[a, b]∘ ∈∘ r ↾l∙ A" 
  using assms unfolding flrestriction_def by simp

lemma flrestrictionD[dest]: 
  assumes "[a, b]∘ ∈∘ r ↾l∙ A"  
  shows "a ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding flrestriction_def by auto

lemma flrestrictionE[elim!]: 
  assumes "x ∈∘ r ↾l∙ A"
  obtains a b where "x = [a, b]∘" and "a ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding flrestriction_def by auto


text‹Set operations.›

lemma flrestriction_on_vempty[simp]: "r ↾l∙ 0 = 0" by auto

lemma flrestriction_vempty[simp]: "0 ↾l∙ A = 0" by auto

lemma flrestriction_vsingleton_in[simp]: 
  assumes "a ∈∘ A"
  shows "set {[a, b]∘} ↾l∙ A = set {[a, b]∘}" 
  using assms by auto

lemma flrestriction_vsingleton_nin[simp]: 
  assumes "a ∉∘ A"
  shows "set {[a, b]∘} ↾l∙ A = 0" 
  using assms by auto

lemma flrestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾l∙ A ⊆∘ r ↾l∙ B"
  using assms by auto

lemma flrestriction_vinsert_nin[simp]: 
  assumes "a ∉∘ A"
  shows "(vinsert [a, b]∘ r) ↾l∙ A = r ↾l∙ A" 
  using assms by auto

lemma flrestriction_vinsert_in: 
  assumes "a ∈∘ A"
  shows "(vinsert [a, b]∘ r) ↾l∙ A = vinsert [a, b]∘ (r ↾l∙ A)" 
  using assms by auto

lemma flrestriction_vintersection: "(r ∩∘ s) ↾l∙ A = r ↾l∙ A ∩∘ s ↾l∙ A" by auto

lemma flrestriction_vunion: "(r ∪∘ s) ↾l∙ A = r ↾l∙ A ∪∘ s ↾l∙ A" by auto

lemma flrestriction_vdiff: "(r -∘ s) ↾l∙ A = r ↾l∙ A -∘ s ↾l∙ A" by auto


text‹Connections.›

lemma flrestriction_fid_on[simp]: "(fid_on A) ↾l∙ B = fid_on (A ∩∘ B)" by auto

lemma flrestriction_fconst_on: "(fconst_on A c) ↾l∙ B = (fconst_on B c) ↾l∙ A"
  by auto

lemma flrestriction_fconst_on_commute:
  assumes "x ∈∘ fconst_on A c ↾l∙ B"
  shows "x ∈∘ fconst_on B c ↾l∙ A"
  using assms by auto

lemma flrestriction_fcomp[simp]: "(r ∘∙ s) ↾l∙ A = r ∘∙ (s ↾l∙ A)" by auto


text‹Previous connections.›

lemma fcomp_rel_fid_on[simp]: "r ∘∙ fid_on A = r ↾l∙ A" by auto

lemma fcomp_fconst_on: 
  "r ∘∙ (fconst_on A c) = (r ↾l∙ set {c}) ∘∙ (fconst_on A c)" 
  by auto


text‹Special properties.›

lemma flrestriction_vsubset_fpairs: "r ↾l∙ A ⊆∘ fpairs r"
  by (rule vsubsetI) (metis fpairs_iff_elts flrestrictionE)

lemma flrestriction_vsubset_frel: "r ↾l∙ A ⊆∘ r" by auto


subsubsection‹Right restriction›

definition frrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾r∙› 80)
  where "r ↾r∙ A = set {[a, b]∘ | a b. b ∈∘ A ∧ [a, b]∘ ∈∘ r}"

lemma frrestriction_small[simp]: "small {[a, b]∘ | a b. b ∈∘ A ∧ [a, b]∘ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma frrestrictionI[intro!]: 
  assumes "b ∈∘ A" and "[a, b]∘ ∈∘ r" 
  shows "[a, b]∘ ∈∘ r ↾r∙ A" 
  using assms unfolding frrestriction_def by simp

lemma frrestrictionD[dest]: 
  assumes "[a, b]∘ ∈∘ r ↾r∙ A"  
  shows "b ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding frrestriction_def by auto

lemma frrestrictionE[elim!]: 
  assumes "x ∈∘ r ↾r∙ A"
  obtains a b where "x = [a, b]∘" and "b ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding frrestriction_def by auto


text‹Set operations.›

lemma frrestriction_on_vempty[simp]: "r ↾r∙ 0 = 0" by auto

lemma frrestriction_vempty[simp]: "0 ↾r∙ A = 0" by auto

lemma frrestriction_vsingleton_in[simp]: 
  assumes "b ∈∘ A"
  shows "set {[a, b]∘} ↾r∙ A = set {[a, b]∘}" 
  using assms by auto

lemma frrestriction_vsingleton_nin[simp]: 
  assumes "b ∉∘ A"
  shows "set {[a, b]∘} ↾r∙ A = 0" 
  using assms by auto

lemma frrestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾r∙ A ⊆∘ r ↾r∙ B"
  using assms by auto

lemma frrestriction_vinsert_nin[simp]:
  assumes "b ∉∘ A"
  shows "(vinsert [a, b]∘ r) ↾r∙ A = r ↾r∙ A" 
  using assms by auto

lemma frrestriction_vinsert_in: 
  assumes "b ∈∘ A"
  shows "(vinsert [a, b]∘ r) ↾r∙ A = vinsert [a, b]∘ (r ↾r∙ A)" 
  using assms by auto

lemma frrestriction_vintersection: "(r ∩∘ s) ↾r∙ A = r ↾r∙ A ∩∘ s ↾r∙ A" by auto

lemma frrestriction_vunion: "(r ∪∘ s) ↾r∙ A = r ↾r∙ A ∪∘ s ↾r∙ A" by auto

lemma frrestriction_vdiff: "(r -∘ s) ↾r∙ A = r ↾r∙ A -∘ s ↾r∙ A" by auto


text‹Connections.›

lemma frrestriction_fid_on[simp]: "(fid_on A) ↾r∙ B = fid_on (A ∩∘ B)" by auto

lemma frrestriction_fconst_on:
  assumes "c ∈∘ B"
  shows "(fconst_on A c) ↾r∙ B = fconst_on A c"  
  using assms by auto

lemma frrestriction_fcomp[simp]: "(r ∘∙ s) ↾r∙ A = (r ↾r∙ A) ∘∙ s" by auto


text‹Previous connections.›

lemma fcomp_fid_on_rel[simp]: "fid_on A ∘∙ r = r ↾r∙ A" by force

lemma fcomp_fconst_on_rel: "(fconst_on A c) ∘∙ r = (fconst_on A c) ∘∙ (r ↾r∙ A)" 
  by auto

lemma flrestriction_fconverse: "r¯∙ ↾l∙ A = (r ↾r∙ A)¯∙" by auto

lemma frrestriction_fconverse: "r¯∙ ↾r∙ A = (r ↾l∙ A)¯∙" by auto


text‹Special properties.›

lemma frrestriction_vsubset_rel: "r ↾r∙ A ⊆∘ r" by auto

lemma frrestriction_vsubset_vpairs: "r ↾r∙ A ⊆∘ fpairs r" by auto


subsubsection‹Restriction›

definition frestriction :: "V ⇒ V ⇒ V" (infixr ‹↾∙› 80)
  where "r ↾∙ A = set {[a, b]∘ | a b. a ∈∘ A ∧ b ∈∘ A ∧ [a, b]∘ ∈∘ r}"

lemma frestriction_small[simp]: 
  "small {[a, b]∘ | a b. a ∈∘ A ∧ b ∈∘ A ∧ [a, b]∘ ∈∘ r}"
  by (rule down[of _ r]) auto


text‹Rules.›

lemma frestrictionI[intro!]: 
  assumes "a ∈∘ A" and "b ∈∘ A" and "[a, b]∘ ∈∘ r" 
  shows "[a, b]∘ ∈∘ r ↾∙ A" 
  using assms unfolding frestriction_def by simp

lemma frestrictionD[dest]: 
  assumes "[a, b]∘ ∈∘ r ↾∙ A"  
  shows "a ∈∘ A" and "b ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding frestriction_def by auto

lemma frestrictionE[elim!]:
  assumes "x ∈∘ r ↾∙ A"
  obtains a b where "x = [a, b]∘" and "a ∈∘ A" and "b ∈∘ A" and "[a, b]∘ ∈∘ r"
  using assms unfolding frestriction_def by clarsimp


text‹Set operations.›

lemma frestriction_on_vempty[simp]: "r ↾∙ 0 = 0" by auto

lemma frestriction_vempty[simp]: "0 ↾∙ A = 0" by auto

lemma frestriction_vsingleton_in[simp]: 
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "set {[a, b]∘} ↾∙ A = set {[a, b]∘}" 
  using assms by auto

lemma frestriction_vsingleton_nin_left[simp]: 
  assumes "a ∉∘ A"
  shows "set {[a, b]∘} ↾∙ A = 0" 
  using assms by auto

lemma frestriction_vsingleton_nin_right[simp]: 
  assumes "b ∉∘ A"
  shows "set {[a, b]∘} ↾∙ A = 0" 
  using assms by auto

lemma frestriction_mono: 
  assumes "A ⊆∘ B"
  shows "r ↾∙ A ⊆∘ r ↾∙ B"
  using assms by auto

lemma frestriction_vinsert_nin[simp]: 
  assumes "a ∉∘ A" and "b ∉∘ A"
  shows "(vinsert [a, b]∘ r) ↾∙ A = r ↾∙ A" 
  using assms by auto

lemma frestriction_vinsert_in: 
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "(vinsert [a, b]∘ r) ↾∙ A = vinsert [a, b]∘ (r ↾∙ A)" 
  using assms by auto

lemma frestriction_vintersection: "(r ∩∘ s) ↾∙ A = r ↾∙ A ∩∘ s ↾∙ A" by auto

lemma frestriction_vunion: "(r ∪∘ s) ↾∙ A = r ↾∙ A ∪∘ s ↾∙ A" by auto

lemma frestriction_vdiff: "(r -∘ s) ↾∙ A = r ↾∙ A -∘ s ↾∙ A" by auto


text‹Connections.›

lemma fid_on_frestriction[simp]: "(fid_on A) ↾∙ B = fid_on (A ∩∘ B)" by auto

lemma frestriction_fconst_on_ex:
  assumes "c ∈∘ B"
  shows "(fconst_on A c) ↾∙ B = fconst_on (A ∩∘ B) c"  
  using assms by auto

lemma frestriction_fconst_on_nex:
  assumes "c ∉∘ B"
  shows "(fconst_on A c) ↾∙ B = 0"  
  using assms by auto

lemma frestriction_fcomp[simp]: "(r ∘∙ s) ↾∙ A = (r ↾r∙ A) ∘∙ (s ↾l∙ A)" by auto

lemma frestriction_fconverse: "r¯∙ ↾∙ A = (r ↾∙ A)¯∙" by auto


text‹Previous connections.›

lemma frrestriction_flrestriction[simp]: "(r ↾r∙ A) ↾l∙ A = r ↾∙ A" by auto

lemma flrestriction_frrestriction[simp]: "(r ↾l∙ A) ↾r∙ A = r ↾∙ A" by auto

lemma frestriction_flrestriction[simp]: "(r ↾∙ A) ↾l∙ A = r ↾∙ A" by auto

lemma frestriction_frrestriction[simp]: "(r ↾∙ A) ↾r∙ A = r ↾∙ A" by auto


text‹Special properties.›

lemma frestriction_vsubset_fpairs: "r ↾∙ A ⊆∘ fpairs r" by auto

lemma frestriction_vsubset_ftimes: "r ↾∙ A ⊆∘ A ^× 2ℕ" by force

lemma frestriction_vsubset_rel: "r ↾∙ A ⊆∘ r" by auto



subsection‹Properties›


subsubsection‹Domain›

definition fdomain :: "V ⇒ V" (‹𝒟∙›)
  where "𝒟∙ r = set {a. ∃b. [a, b]∘ ∈∘ r}"
notation fdomain (‹𝒟∙›)

lemma fdomain_small[simp]: "small {a. ∃b. [a, b]∘ ∈∘ r}"
proof-
  have ss: "{a. ∃b. [a, b]∘ ∈∘ r} ⊆ (λx. x⦇0ℕ⦈) ` elts r" 
    using image_iff by force
  have small: "small ((λx. x⦇0ℕ⦈) ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma fdomainI[intro]: 
  assumes "[a, b]∘ ∈∘ r"
  shows "a ∈∘ 𝒟∙ r"
  using assms unfolding fdomain_def by auto

lemma fdomainD[dest]: 
  assumes "a ∈∘ 𝒟∙ r"
  shows "∃b. [a, b]∘ ∈∘ r" 
  using assms unfolding fdomain_def by auto

lemma fdomainE[elim]:
  assumes "a ∈∘ 𝒟∙ r"
  obtains b where "[a, b]∘ ∈∘ r"
  using assms unfolding fdomain_def by clarsimp

lemma fdomain_iff: "a ∈∘ 𝒟∙ r ⟷ (∃y. [a, y]∘ ∈∘ r)" by auto


text‹Set operations.›

lemma fdomain_vempty[simp]: "𝒟∙ 0 = 0" by force

lemma fdomain_vsingleton[simp]: "𝒟∙ (set {[a, b]∘}) = set {a}" by auto

lemma fdomain_vdoubleton[simp]: "𝒟∙ (set {[a, b]∘, [c, d]∘}) = set {a, c}" 
  by force

lemma fdomain_mono: 
  assumes "r ⊆∘ s"
  shows "𝒟∙ r ⊆∘ 𝒟∙ s"
  using assms by blast

lemma fdomain_vinsert[simp]: "𝒟∙ (vinsert [a, b]∘ r) = vinsert a (𝒟∙ r)" 
  by force

lemma fdomain_vunion: "𝒟∙ (A ∪∘ B) = 𝒟∙ A ∪∘ 𝒟∙ B" by force

lemma fdomain_vintersection_vsubset: "𝒟∙ (A ∩∘ B) ⊆∘ 𝒟∙ A ∩∘ 𝒟∙ B" by auto

lemma fdomain_vdiff_vsubset: "𝒟∙ A -∘ 𝒟∙ B ⊆∘ 𝒟∙ (A -∘ B)" by auto


text‹Connections.›

lemma fdomain_fid_on[simp]: "𝒟∙ (fid_on A) = A" by force

lemma fdomain_fconst_on[simp]: "𝒟∙ (fconst_on A c) = A" by force

lemma fdomain_flrestriction: "𝒟∙ (r ↾l∙ A) = 𝒟∙ r ∩∘ A" by auto


text‹Special properties.›

lemma fdomain_vsubset_ftimes:
  assumes "fpairs r ⊆∘ A ×∙ B"
  shows "𝒟∙ r ⊆∘ A"
  using assms by blast

lemma fdomain_vsubset_VUnion2: "𝒟∙ r ⊆∘ ⋃∘(⋃∘(⋃∘r))"
proof(intro vsubsetI)
  fix x assume "x ∈∘ 𝒟∙ r"
  then obtain y where "[x, y]∘ ∈∘ r" by auto
  then have "set {⟨0ℕ, x⟩, ⟨1ℕ, y⟩} ∈∘ r" unfolding vcons_vdoubleton by simp
  with insert_commute have "⟨0ℕ, x⟩ ∈∘ ⋃∘r" by auto
  then show "x ∈∘ ⋃∘(⋃∘(⋃∘r))" 
    unfolding vpair_def 
    by (metis (full_types) VUnion_iff insert_commute vintersection_vdoubleton)
qed


subsubsection‹Range›

definition frange :: "V ⇒ V" (‹ℛ∙›)
  where "frange r = set {b. ∃a. [a, b]∘ ∈∘ r}"
notation frange (‹ℛ∙›)

lemma frange_small[simp]: "small {b. ∃a. [a, b]∘ ∈∘ r}"
proof-
  have ss: "{b. ∃a. [a, b]∘ ∈∘ r} ⊆ (λx. x⦇1ℕ⦈) ` elts r" 
    using image_iff by (fastforce simp: nat_omega_simps)
  have small: "small ((λx. x⦇1ℕ⦈) ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma frangeI[intro]: 
  assumes "[a, b]∘ ∈∘ r"
  shows "b ∈∘ ℛ∙ r"
  using assms unfolding frange_def by auto

lemma frangeD[dest]: 
  assumes "b ∈∘ ℛ∙ r"
  shows "∃a. [a, b]∘ ∈∘ r" 
  using assms unfolding frange_def by simp

lemma frangeE[elim!]:
  assumes "b ∈∘ ℛ∙ r"
  obtains a where "[a, b]∘ ∈∘ r"
  using assms unfolding frange_def by clarsimp

lemma frange_iff: "b ∈∘ ℛ∙ r ⟷ (∃a. [a, b]∘ ∈∘ r)" by auto


text‹Set operations.›

lemma frange_vempty[simp]: "ℛ∙ 0 = 0" by auto

lemma frange_vsingleton[simp]: "ℛ∙ (set {[a, b]∘}) = set {b}" by auto

lemma frange_vdoubleton[simp]: "ℛ∙ (set {[a, b]∘, [c, d]∘}) = set {b, d}" 
  by force

lemma frange_mono: 
  assumes "r ⊆∘ s" 
  shows "ℛ∙ r ⊆∘ ℛ∙ s"
  using assms by force

lemma frange_vinsert[simp]: "ℛ∙ (vinsert [a, b]∘ r) = vinsert b (ℛ∙ r)" by auto

lemma frange_vunion: "ℛ∙ (r ∪∘ s) = ℛ∙ r ∪∘ ℛ∙ s" by auto

lemma frange_vintersection_vsubset: "ℛ∙ (r ∩∘ s) ⊆∘ ℛ∙ r ∩∘ ℛ∙ s" by auto

lemma frange_vdiff_vsubset: "ℛ∙ r -∘ ℛ∙ s ⊆∘ ℛ∙ (r -∘ s)" by auto


text‹Connections.›

lemma frange_fid_on[simp]: "ℛ∙ (fid_on A) = A" by force

lemma frange_fconst_on_vempty[simp]: "ℛ∙ (fconst_on 0 c) = 0" by auto

lemma frange_fconst_on_ne[simp]: 
  assumes "A ≠ 0"
  shows "ℛ∙ (fconst_on A c) = set {c}"
  using assms by force

lemma frange_vrrestriction: "ℛ∙ (r ↾r∙ A) = ℛ∙ r ∩∘ A" by auto


text‹Previous connections›

lemma fdomain_fconverse[simp]: "𝒟∙ (r¯∙) = ℛ∙ r" by auto

lemma frange_fconverse[simp]: "ℛ∙ (r¯∙) = 𝒟∙ r" by force


text‹Special properties.›

lemma frange_iff_vdomain: "b ∈∘ ℛ∙ r ⟷ (∃a∈∘𝒟∙ r. [a, b]∘ ∈∘ r)" by auto

lemma frange_vsubset_ftimes:
  assumes "fpairs r ⊆∘ A ×∙ B"
  shows "ℛ∙ r ⊆∘ B"
  using assms by blast

lemma fpairs_vsubset_fdomain_frange[simp]: "fpairs r ⊆∘ (𝒟∙ r) ×∙ (ℛ∙ r)" 
  by blast

lemma frange_vsubset_VUnion2: "ℛ∙ r ⊆∘ ⋃∘(⋃∘(⋃∘r))"
proof(intro vsubsetI)
  fix y assume "y ∈∘ ℛ∙ r"
  then obtain x where "[x, y]∘ ∈∘ r" by auto
  then have "set {⟨0ℕ, x⟩, ⟨1ℕ, y⟩} ∈∘ r" unfolding vcons_vdoubleton by simp
  with insert_commute have "⟨1ℕ, y⟩ ∈∘ ⋃∘r" by auto
  then show "y ∈∘ ⋃∘(⋃∘(⋃∘r))" 
    unfolding vpair_def 
    by (metis (full_types) VUnion_iff insert_commute vintersection_vdoubleton)
qed
  

subsubsection‹Field›

definition ffield :: "V ⇒ V"
  where "ffield r = 𝒟∙ r ∪∘ ℛ∙ r"

abbreviation app_ffield :: "V ⇒ V" (‹ℱ∙›)
  where "ℱ∙ r ≡ ffield r"


text‹Rules.›

lemma ffieldI1[intro]: 
  assumes "a ∈∘ 𝒟∙ r ∪∘ ℛ∙ r"
  shows "a ∈∘ ffield r"
  using assms unfolding ffield_def by simp

lemma ffieldI2[intro]: 
  assumes "[a, b]∘ ∈∘ r"
  shows "a ∈∘ ffield r"
  using assms by auto

lemma ffieldI3[intro]: 
  assumes "[a, b]∘ ∈∘ r"
  shows "b ∈∘ ffield r"
  using assms by auto

lemma ffieldD[intro]: 
  assumes "a ∈∘ ffield r"
  shows "a ∈∘ 𝒟∙ r ∪∘ ℛ∙ r"
  using assms unfolding ffield_def by simp

lemma ffieldE[elim]:  
  assumes "a ∈∘ ffield r" and "a ∈∘ 𝒟∙ r ∪∘ ℛ∙ r ⟹ P"
  shows P
  using assms by (auto dest: ffieldD)

lemma ffield_pair[elim]:
  assumes "a ∈∘ ffield r"
  obtains b where "[a, b]∘ ∈∘ r ∨ [b, a]∘ ∈∘ r "
  using assms by auto

lemma ffield_iff: "a ∈∘ ffield r ⟷ (∃b. [a, b]∘ ∈∘ r ∨ [b, a]∘ ∈∘ r)" by auto


text‹Set operations.›

lemma ffield_vempty[simp]: "ffield 0 = 0" by force

lemma ffield_vsingleton[simp]: "ffield (set {[a, b]∘}) = set {a, b}" by force

lemma ffield_vdoubleton[simp]: 
  "ffield (set {[a, b]∘, [c, d]∘}) = set {a, b, c, d}" 
  by force

lemma ffield_mono:
  assumes "r ⊆∘ s" 
  shows "ffield r ⊆∘ ffield s"
  using assms by fastforce

lemma ffield_vinsert[simp]: 
  "ffield (vinsert [a, b]∘ r) = set {a, b} ∪∘ (ffield r)"
  apply (intro vsubset_antisym; intro vsubsetI)
  subgoal by auto
  subgoal by (metis ffield_iff vinsert_iff vinsert_vinsert)
  done

lemma ffield_vunion[simp]: "ffield (r ∪∘ s) = ffield r ∪∘ ffield s" 
  unfolding ffield_def by auto


text‹Connections.›

lemma fid_on_ffield[simp]: "ffield (fid_on A) = A" by force

lemma fconst_on_ffield_ne[intro, simp]:
  assumes "A ≠ 0" 
  shows "ffield (fconst_on A c) = vinsert c A" 
  using assms by force

lemma fconst_on_ffield_vempty[simp]: "ffield (fconst_on 0 c) = 0" by auto

lemma ffield_fconverse[simp]: "ffield (r¯∙) = ffield r" by force


text‹Special properties.›

lemma ffield_vsubset_VUnion2: "ℱ∙ r ⊆∘ ⋃∘(⋃∘(⋃∘r))"
  using fdomain_vsubset_VUnion2 frange_vsubset_VUnion2 by (auto simp: ffield_def)


subsubsection‹Image›

definition fimage :: "V ⇒ V ⇒ V" (infixr ‹`∙› 90)
  where "r `∙ A = ℛ∙ (r ↾l∙ A)"
notation fimage (infixr "`∙" 90)

lemma fimage_small[simp]: "small {b. ∃a∈∘A. [a, b]∘ ∈∘ r}"
proof-
  from image_iff ord_of_nat_succ_vempty have ss: 
    "{b. ∃a∈∘A. [a, b]∘ ∈∘ r} ⊆ (λx. x⦇1ℕ⦈) ` elts r"         
    by fastforce
  have small: "small ((λx. x⦇1ℕ⦈) ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma fimageI1: 
  assumes "x ∈∘ ℛ∙ (r ↾l∙ A)"
  shows "x ∈∘ r `∙ A" 
  using assms unfolding fimage_def by simp

lemma fimageI2[intro]:
  assumes "[a, b]∘ ∈∘ r" and "a ∈∘ A" 
  shows "b ∈∘ r `∙ A"
  using assms fimageI1 by auto

lemma fimageD[dest]: 
  assumes "x ∈∘ r `∙ A"
  shows "x ∈∘ ℛ∙ (r ↾l∙ A)"
  using assms unfolding fimage_def by simp

lemma fimageE[elim]:
  assumes "b ∈∘ r `∙ A"
  obtains a where "[a, b]∘ ∈∘ r" and "a ∈∘ A"
  using assms unfolding fimage_def by auto

lemma fimage_iff: "b ∈∘ r `∙ A ⟷ (∃a∈∘A. [a, b]∘ ∈∘ r)" by auto


text‹Set operations.›

lemma fimage_vempty[simp]: "0 `∙ A = 0" by force

lemma fimage_of_vempty[simp]: "r `∙ 0 = 0" by force

lemma fimage_vsingleton_in[intro, simp]: 
  assumes "a ∈∘ A" 
  shows "set {[a, b]∘} `∙ A = set {b}" 
  using assms by auto

lemma fimage_vsingleton_nin[intro, simp]: 
  assumes "a ∉∘ A" 
  shows "set {[a, b]∘} `∙ A = 0" 
  using assms by auto

lemma fimage_vsingleton_vinsert[intro, simp]: 
  "set {[a, b]∘} `∙ vinsert a A = set {b}" 
  by auto

lemma fimage_mono: 
  assumes "r' ⊆∘ r" and "A' ⊆∘ A" 
  shows "(r' `∙ A') ⊆∘ (r `∙ A)" 
  using assms by fastforce

lemma fimage_vinsert: "r `∙ (vinsert a A) = r `∙ set {a} ∪∘ r `∙ A" by auto

lemma fimage_vunion_left: "(r ∪∘ s) `∙ A = r `∙ A ∪∘ s `∙ A" by auto

lemma fimage_vunion_right: "r `∙ (A ∪∘ B) = r `∙ A ∪∘ r `∙ B" by auto

lemma fimage_vintersection: "r `∙ (A ∩∘ B) ⊆∘ r `∙ A ∩∘ r `∙ B" by auto

lemma fimage_vdiff: "r `∙ A -∘ r `∙ B ⊆∘ r `∙ (A -∘ B)" by auto


text‹Special properties.›

lemma fimage_vsingleton_iff[iff]: "b ∈∘ r `∙ set {a} ⟷ [a, b]∘ ∈∘ r" by auto

lemma fimage_is_vempty[iff]: "r `∙ A = 0 ⟷ vdisjnt (𝒟∙ r) A" by fastforce


text‹Connections.›

lemma fid_on_fimage[simp]: "(fid_on A) `∙ B = A ∩∘ B" by force

lemma fimage_fconst_on_ne[simp]: 
  assumes "B ∩∘ A ≠ 0" 
  shows "(fconst_on A c) `∙ B = set {c}" 
  using assms by auto

lemma fimage_fconst_on_vempty[simp]: 
  assumes "vdisjnt A B"
  shows "(fconst_on A c) `∙ B = 0" 
  using assms by auto

lemma fimage_fconst_on_vsubset_const[simp]: "(fconst_on A c) `∙ B ⊆∘ set {c}" 
  by auto

lemma fcomp_frange: "ℛ∙ (r ∘∙ s) = r `∙ (ℛ∙ s)" by blast

lemma fcomp_fimage: "(r ∘∙ s) `∙ A = r `∙ (s `∙ A)" by blast

lemma fimage_flrestriction[simp]: "(r ↾l∙ A) `∙ B = r `∙ (A ∩∘ B)" by auto

lemma fimage_frrestriction[simp]: "(r ↾r∙ A) `∙ B = A ∩∘ r `∙ B" by auto

lemma fimage_frestriction[simp]: "(r ↾∙ A) `∙ B = A ∩∘ (r `∙ (A ∩∘ B))" by auto

lemma fimage_fdomain: "r `∙ 𝒟∙ r = ℛ∙ r" by auto

lemma fimage_eq_imp_fcomp: 
  assumes "f `∙ A = g `∙ B" 
  shows "(h ∘∙ f) `∙ A = (h ∘∙ g) `∙ B"
  using assms by (metis fcomp_fimage)


text‹Previous connections.›

lemma fcomp_rel_fconst_on_ftimes: "r ∘∙ (fconst_on A c) = A ×∙ (r `∙ set {c})" 
  by blast


text‹Further special properties.›

lemma fimage_vsubset: 
  assumes "r ⊆∘ A ×∙ B" 
  shows "r `∙ C ⊆∘ B" 
  using assms by blast

lemma fimage_set_def: "r `∙ A = set {b. ∃a∈∘A. [a, b]∘ ∈∘ r}"
  unfolding fimage_def frange_def by auto

lemma fimage_vsingleton: "r `∙ set {a} = set {b. [a, b]∘ ∈∘ r}"
proof-
  have "{b. [a, b]∘ ∈∘ r} ⊆ {b. ∃a. [a, b]∘ ∈∘ r}" by auto
  then have [simp]: "small {b. [a, b]∘ ∈∘ r}" 
    by (rule smaller_than_small[OF frange_small[of r]])
  show ?thesis by auto
qed

lemma fimage_strict_vsubset: "f `∙ A ⊆∘ f `∙ 𝒟∙ f" by auto


subsubsection‹Inverse image›

definition finvimage :: "V ⇒ V ⇒ V" (infixr ‹-`∙› 90)
  where "r -`∙ A = r¯∙ `∙ A"

lemma finvimage_small[simp]: "small {a. ∃b∈∘A. [a, b]∘ ∈∘ r}"
proof-
  have ss: "{a. ∃b∈∘A. [a, b]∘ ∈∘ r} ⊆ (λx. x⦇0ℕ⦈) ` elts r" 
    using image_iff by fastforce
  have small: "small ((λx. x⦇0ℕ⦈) ` elts r)" by (rule replacement) simp
  show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed


text‹Rules.›

lemma finvimageI[intro]:
  assumes "[a, b]∘ ∈∘ r" and "b ∈∘ A" 
  shows "a ∈∘ r -`∙ A"
  using assms finvimage_def by auto

lemma finvimageD[dest]: 
  assumes "a ∈∘ r -`∙ A"
  shows "a ∈∘ 𝒟∙ (r ↾r∙ A)"
  using assms using finvimage_def by auto

lemma finvimageE[elim]:
  assumes "a ∈∘ r -`∙ A"
  obtains b where "[a, b]∘ ∈∘ r" and "b ∈∘ A"
  using assms unfolding finvimage_def by auto

lemma finvimageI1: 
  assumes "a ∈∘ 𝒟∙ (r ↾r∙ A)"
  shows "a ∈∘ r -`∙ A" 
  using assms unfolding fimage_def 
  by (simp add: finvimage_def fimageI1 flrestriction_fconverse)

lemma finvimageD1: 
  assumes "a ∈∘ r -`∙ A"
  shows "a ∈∘ 𝒟∙ (r ↾r∙ A)"
  using assms by fastforce

lemma finvimageE1:
  assumes "a ∈∘ r -`∙ A " and "a ∈∘ 𝒟∙ (r ↾r∙ A) ⟹ P"
  shows P
  using assms by auto

lemma finvimageI2: 
  assumes "a ∈∘ r¯∙ `∙ A"
  shows "a ∈∘ r -`∙ A" 
  using assms unfolding finvimage_def by simp

lemma finvimageD2:
  assumes "a ∈∘ r -`∙ A"
  shows "a ∈∘ r¯∙ `∙ A"
  using assms unfolding finvimage_def by simp

lemma finvimageE2:
  assumes "a ∈∘ r -`∘ A" and "a ∈∘ r¯∘ `∘ A ⟹ P"
  shows P
  unfolding vimage_def using assms by blast

lemma finvimage_iff: "a ∈∘ r -`∙ A ⟷ (∃b∈∘A. [a, b]∘ ∈∘ r)" by auto

lemma finvimage_iff1: "a ∈∘ r -`∙ A ⟷ a ∈∘ 𝒟∙ (r ↾r∙ A)" by auto

lemma finvimage_iff2: "a ∈∘ r -`∙ A ⟷ a ∈∘ r¯∙ `∙ A" by auto


text‹Set operations.›

lemma finvimage_vempty[simp]: "0 -`∙ A = 0" by force

lemma finvimage_of_vempty[simp]: "r -`∙ 0 = 0" by force

lemma finvimage_vsingleton_in[intro, simp]: 
  assumes "b ∈∘ A"
  shows "set {[a, b]∘} -`∙ A = set {a}" 
  using assms by auto

lemma finvimage_vsingleton_nin[intro, simp]: 
  assumes "b ∉∘ A"
  shows "set {[a, b]∘} -`∙ A = 0" 
  using assms by auto

lemma finvimage_vsingleton_vinsert[intro, simp]: 
  "set {[a, b]∘} -`∙ vinsert b A = set {a}" 
  by auto

lemma finvimage_mono: 
  assumes "r' ⊆∘ r" and "A' ⊆∘ A"
  shows "(r' -`∙ A') ⊆∘ (r -`∙ A)" 
  using assms by fastforce

lemma finvimage_vinsert: "r -`∙ (vinsert a A) = r -`∙ set {a} ∪∘ r -`∙ A" by auto

lemma finvimage_vunion_left: "(r ∪∘ s) -`∙ A = r -`∙ A ∪∘ s -`∙ A" by auto

lemma finvimage_vunion_right: "r -`∙ (A ∪∘ B) = r -`∙ A ∪∘ r -`∙ B" by auto

lemma finvimage_vintersection: "r -`∙ (A ∩∘ B) ⊆∘ r -`∙ A ∩∘ r -`∙ B" by auto

lemma finvimage_vdiff: "r -`∙ A -∘ r -`∙ B ⊆∘ r -`∙ (A -∘ B)" by auto


text‹Special properties.›

lemma finvimage_set_def: "r -`∙ A = set {a. ∃b∈∘A. [a, b]∘ ∈∘ r}" by fastforce

lemma finvimage_eq_fdomain_frestriction: "r -`∙ A = 𝒟∙ (r ↾r∙ A)" by fastforce

lemma finvimage_frange[simp]: "r -`∙ ℛ∙ r = 𝒟∙ r"
  unfolding invimage_def by force

lemma finvimage_frange_vsubset[simp]: 
  assumes "ℛ∙ r ⊆∘ B" 
  shows "r -`∙ B = 𝒟∙ r"
  using assms unfolding finvimage_def by force


text‹Connections.›

lemma finvimage_fid_on[simp]: "(fid_on A) -`∙ B = A ∩∘ B" by force

lemma finvimage_fconst_on_vsubset_fdomain[simp]: "(fconst_on A c) -`∙ B ⊆∘ A" 
  unfolding finvimage_def by blast

lemma finvimage_fconst_on_ne[simp]: 
  assumes "c ∈∘ B"
  shows "(fconst_on A c) -`∙ B = A" 
  by (simp add: assms finvimage_eq_fdomain_frestriction frrestriction_fconst_on)

lemma finvimage_fconst_on_vempty[simp]: 
  assumes "c ∉∘ B"
  shows "(fconst_on A c) -`∙ B = 0" 
  using assms by auto

lemma finvimage_fcomp: "(g ∘∙ f) -`∙ x = f -`∙ (g -`∙ x) "
  by (simp add: finvimage_def fconverse_fcomp fcomp_fimage)

lemma finvimage_fconverse[simp]: "r¯∙ -`∙ A = r `∙ A" by auto

lemma finvimage_flrestriction[simp]: "(r ↾l∙ A) -`∙ B = A ∩∘ r -`∙ B" by auto

lemma finvimage_frrestriction[simp]: "(r ↾r∙ A) -`∙ B = (r -`∙ (A ∩∘ B))" by auto

lemma finvimage_frestriction[simp]: "(r ↾∙ A) -`∙ B = A ∩∘ (r -`∙ (A ∩∘ B))" 
  by blast


text‹Previous connections.›

lemma fdomain_fcomp[simp]: "𝒟∙ (r ∘∙ s) = s -`∙ 𝒟∙ r" by force



subsection‹Classification of relations›


subsubsection‹Binary relation›

locale fbrelation = 
  fixes r :: V
  assumes fbrelation[simp]: "fpairs r = r"

locale fbrelation_pair = r1: fbrelation r1 + r2: fbrelation r2 for r1 r2


text‹Rules.›

lemma fpairs_eqI[intro!]:
  assumes "⋀x. x ∈∘ r ⟹ ∃a b. x = [a, b]∘"
  shows "fpairs r = r"
  using assms by auto

lemma fpairs_eqD[dest]: 
  assumes "fpairs r = r"
  shows "⋀x. x ∈∘ r ⟹ ∃a b. x = [a, b]∘"
  using assms by auto

lemma fpairs_eqE[elim!]: 
  assumes "fpairs r = r" and "(⋀x. x ∈∘ r ⟹ ∃a b. x = [a, b]∘) ⟹ P"
  shows P
  using assms by auto

lemmas fbrelationI[intro!] = fbrelation.intro 
lemmas fbrelationD[dest!] = fbrelation.fbrelation

lemma fbrelationE[elim!]: 
  assumes "fbrelation r" and "(fpairs r = r) ⟹ P"
  shows P
  using assms unfolding fbrelation_def by auto

lemma fbrelationE1:
  assumes "fbrelation r" and "x ∈∘ r" 
  obtains a b where "x = [a, b]∘"
  using assms by auto

lemma fbrelationD1[dest]:
  assumes "fbrelation r" and "x ∈∘ r" 
  shows "∃a b. x = [a, b]∘"
  using assms by auto


text‹Set operations.›

lemma fbrelation_vsubset:
  assumes "fbrelation s" and "r ⊆∘ s" 
  shows "fbrelation r"
  using assms by auto

lemma fbrelation_vinsert: "fbrelation (vinsert [a, b]∘ r) ⟷ fbrelation r"  
  by auto

lemma (in fbrelation) fbrelation_vinsertI: "fbrelation (vinsert [a, b]∘ r)"
  using fbrelation_axioms by auto

lemma fbrelation_vinsertD[dest]:
  assumes "fbrelation (vinsert ⟨a, b⟩ r)"
  shows "fbrelation r"
  using assms by auto

lemma fbrelation_vunion: "fbrelation (r ∪∘ s) ⟷ fbrelation r ∧ fbrelation s"
  by auto

lemma (in fbrelation_pair) fbrelation_vunionI: "fbrelation (r1 ∪∘ r2)"
  using r1.fbrelation_axioms r2.fbrelation_axioms by auto

lemma fbrelation_vunionD[dest]: 
  assumes "fbrelation (r ∪∘ s)"
  shows "fbrelation r" and "fbrelation s"
  using assms by auto

lemma (in fbrelation) fbrelation_vintersectionI: "fbrelation (r ∩∘ s)"
  using fbrelation_axioms by auto

lemma (in fbrelation) fbrelation_vdiffI: "fbrelation (r -∘ s)"
  using fbrelation_axioms by auto


text‹Connections.›

lemma fbrelation_vempty: "fbrelation 0" by auto

lemma fbrelation_vsingleton: "fbrelation (set {[a, b]∘})" by auto

global_interpretation frel_vsingleton: fbrelation ‹set {[a, b]∘}› 
  by (rule fbrelation_vsingleton)

lemma fbrelation_vdoubleton: "fbrelation (set {[a, b]∘, [c, d]∘})" by auto

lemma fbrelation_sid_on[simp]: "fbrelation (fid_on A)" by auto

lemma fbrelation_fconst_on[simp]: "fbrelation (fconst_on A c)" by auto

lemma (in fbrelation_pair) fbrelation_fcomp: "fbrelation (r1 ∘∙ r2)" 
  using r1.fbrelation_axioms r2.fbrelation_axioms by auto

sublocale fbrelation_pair ⊆ fcomp21: fbrelation ‹r2 ∘∙ r1›
  by 
    (
      simp add: 
        fbrelation_pair.fbrelation_fcomp 
        fbrelation_pair_def 
        r1.fbrelation_axioms 
        r2.fbrelation_axioms
     )

sublocale fbrelation_pair ⊆ fcomp12: fbrelation ‹r1 ∘∙ r2› 
  by (rule fbrelation_fcomp)

lemma (in fbrelation) fbrelation_fconverse: "fbrelation (r¯∙)"
  using fbrelation_axioms by clarsimp

lemma fbrelation_flrestriction[intro, simp]: "fbrelation (r ↾l∙ A)" by auto

lemma fbrelation_frrestriction[intro, simp]: "fbrelation (r ↾r∙ A)" by auto

lemma fbrelation_frestriction[intro, simp]: "fbrelation (r ↾∙ A)" by auto


text‹Previous connections.›

lemma (in fbrelation) fconverse_fconverse[simp]: "(r¯∙)¯∙ = r"
  using fbrelation_axioms by auto

lemma (in fbrelation_pair) fconverse_mono[simp]: "r1¯∙ ⊆∘ r2¯∙ ⟷ r1 ⊆∘ r2"
  using r1.fbrelation_axioms r2.fbrelation_axioms 
  by (force intro: fconverse_vunion)+

lemma (in fbrelation_pair) fconverse_inject[simp]: "r1¯∙ = r2¯∙ ⟷ r1 = r2"
  using r1.fbrelation_axioms r2.fbrelation_axioms by fast

lemma (in fbrelation) fconverse_vsubset_swap_2: 
  assumes "r¯∙ ⊆∘ s"
  shows "r ⊆∘ s¯∙" 
  using assms fbrelation_axioms by auto

lemma (in fbrelation) flrestriction_fdomain[simp]: "r ↾l∙ 𝒟∙ r = r"
  using fbrelation_axioms by (elim fbrelationE) blast

lemma (in fbrelation) frrestriction_frange[simp]: "r ↾r∙ ℛ∙ r = r"
  using fbrelation_axioms by (elim fbrelationE) blast


text‹Special properties.›

lemma vsubset_vtimes_fbrelation: 
  assumes "r ⊆∘ A ×∙ B"
  shows "fbrelation r" 
  using assms by blast

lemma (in fbrelation) fbrelation_vintersection_vdomain:
  assumes "vdisjnt (𝒟∙ r) (𝒟∙ s)"
  shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "[a, b]∘ ∈∘ r ∩∘ s"
    by (metis fbrelationE1 fbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed simp

lemma (in fbrelation) fbrelation_vintersection_vrange:
  assumes "vdisjnt (ℛ∙ r) (ℛ∙ s)"
  shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "[a, b]∘ ∈∘ r ∩∘ s"
    by (metis fbrelationE1 fbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed simp

lemma (in fbrelation) fbrelation_vintersection_vfield:
  assumes "vdisjnt (ffield r) (ffield s)"
  shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
  fix x assume "x ∈∘ r ∩∘ s"
  then obtain a b where "[a, b]∘ ∈∘ r ∩∘ s"
    by (metis fbrelationE1 fbrelation_vintersectionI)
  with assms show "x ∈∘ 0" by auto
qed auto

lemma (in fbrelation) vdomain_vrange_vtimes: "r ⊆∘ 𝒟∙ r ×∙ ℛ∙ r"
  using fbrelation by blast

lemma (in fbrelation) fconverse_eq_frel[intro, simp]:
  assumes "⋀a b. [a, b]∘ ∈∘ r ⟹ [b, a]∘ ∈∘ r"
  shows "r¯∙ = r"
  using assms
  apply (intro vsubset_antisym; intro vsubsetI)
  subgoal by blast
  subgoal by (metis fconverseE fconverseI fconverse_fconverse)
  done

lemma fcomp_fconverse_frel_eq_frel_fbrelationI:
  assumes "r¯∙ ∘∙ r = r"
  shows "fbrelation r"
  using assms by (intro fbrelationI, elim vequalityE vsubsetE) force


text‹Alternative forms of existing results.›

lemmas [intro, simp] = fbrelation.fconverse_fconverse
  and fconverse_eq_frel[intro, simp] = fbrelation.fconverse_eq_frel

context
  fixes r1 r2
  assumes r1: "fbrelation r1"
    and r2: "fbrelation r2"
begin

lemmas_with[OF fbrelation_pair.intro[OF r1 r2]] :
  fbrelation_fconverse_mono[intro, simp] = fbrelation_pair.fconverse_mono
  and fbrelation_frrestriction_srange[intro, simp] = 
    fbrelation_pair.fconverse_inject

end

text‹\newpage›

end

Theory CZH_Sets_VNHS

(* Copyright 2021 (C) Mihails Milehins *)

section‹Further results related to the von Neumann hierarchy of sets›
theory CZH_Sets_VNHS
  imports 
    CZH_Sets_FBRelations
    CZH_Sets_Ordinals
begin



subsection‹Background›


text‹
The subsection presents several further auxiliary results about the 
von Neumann hierarchy of sets. The primary general reference for this section
is \cite{takeuti_introduction_1971}.
›



subsection‹Further elementary properties of ‹Vfrom››


text‹Reusable patterns.›

lemma Vfrom_Ord_bundle:
  assumes "A = A" and "i = i"
  shows "Vfrom A i = Vfrom A (rank i)" and "Ord (rank i)"
  by (simp_all add: Vfrom_rank_eq )

lemma Vfrom_in_bundle:
  assumes "i ∈∘ j" and "A = A" and "B = B"
  shows "Vfrom A i = Vfrom A (rank i)"
    and "Ord (rank i)"
    and "Vfrom B j = Vfrom B (rank j)"
    and "Ord (rank j)"
    and "rank i ∈∘ rank j"
  by (simp_all add: assms(1) Vfrom_rank_eq Ord_mem_iff_lt rank_lt)


text‹Elementary corollaries.›

lemma Ord_Vset_in_Vset_succI[intro]:
  assumes "Ord α" 
  shows "Vset α ∈∘ Vset (succ α)"
  by (simp add: Vset_succ assms)

lemma Ord_in_in_VsetI[intro]:
  assumes "Ord α" and "a ∈∘ α"
  shows "a ∈∘ Vset α"
  by (metis assms Ord_VsetI Ord_iff_rank rank_lt)


text‹Transitivity of the constant const‹Vfrom›.›

lemma Vfrom_trans[intro]:
  assumes "Transset A" and "x ∈∘ X" and "X ∈∘ Vfrom A i" 
  shows "x ∈∘ Vfrom A i"
  using Transset_def by (blast intro: assms Transset_Vfrom)

lemma Vset_trans[intro]:
  assumes "x ∈∘ X" and "X ∈∘ Vset i" 
  shows "x ∈∘ Vset i"
  by (auto intro: assms)


text‹Monotonicity of the constant const‹Vfrom›.›

lemma Vfrom_in_mono:
  assumes "A ⊆∘ B" and "i ∈∘ j"
  shows "Vfrom A i ∈∘ Vfrom B j"
proof-
  define i' where "i' = rank i"
  define j' where "j' = rank j"
  note rank_conv = 
    Vfrom_in_bundle[
      OF assms(2) HOL.refl[of A] HOL.refl[of B], folded i'_def j'_def
      ]
  show ?thesis
    unfolding rank_conv using rank_conv(4,5)
  proof induction
    case (succ j')
    from succ have "Ord (succ j')" by auto
    from succ(3) succ.hyps have "i' ⊆∘ j'" by (auto simp: Ord_def Transset_def)
    from Vfrom_mono[OF ‹Ord i'› assms(1) this] show ?case 
      unfolding Vfrom_succ_Ord[OF ‹Ord j'›, of B] by simp
  next
    case (Limit j')
    from Limit(3) obtain ξ where "i' ∈∘ ξ" and "ξ ∈∘ j'" by auto
    with vifunionI have "Vfrom A i' ∈∘ (⋃∘ξ∈∘j'. Vfrom B ξ)" 
      by (auto simp: Limit.IH)
    then show "Vfrom A i' ∈∘ Vfrom B (⋃∘ξ∈∘j'. ξ)"
      unfolding Limit_Vfrom_eq[symmetric, OF Limit(1)] 
      by (simp add: SUP_vifunion[symmetric] Limit.hyps)
  qed auto
qed

lemmas Vset_in_mono = Vfrom_in_mono[OF order_refl, of _ _ 0]

lemma Vfrom_vsubset_mono:
  assumes "A ⊆∘ B" and "i ⊆∘ j"
  shows "Vfrom A i ⊆∘ Vfrom B j"
  by (metis assms Vfrom_Ord_bundle(1,2) Vfrom_mono rank_mono)

lemmas Vset_vsubset_mono = Vfrom_vsubset_mono[OF order_refl, of _ _ 0]

lemma arg1_vsubset_Vfrom: "a ⊆∘ Vfrom a i" using Vfrom by blast
                                                     
lemma VPow_vsubset_Vset:
  ―‹Based on Theorem 9.10 from \cite{takeuti_introduction_1971}›
  assumes "X ∈∘ Vset i" 
  shows "VPow X ⊆∘ Vset i"
proof-
  define i' where "i' = rank i"
  note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
  show ?thesis 
    using rank_conv(2) assms unfolding rank_conv
  proof induction
    case (Limit α)
    from Limit have "X ∈∘ (⋃∘i∈∘α. Vset i)"
      by (simp add: SUP_vifunion[symmetric] Limit_Vfrom_eq)
    then have "VPow X ⊆∘ (⋃∘i∈∘α. Vset i)"
      by (intro vsubsetI) (metis Limit.IH vifunionE vifunionI vsubsetE)
    then show ?case 
      by (simp add: SUP_vifunion[symmetric] Limit.hyps Limit_Vfrom_eq)
  qed (simp_all add: Vset_succ)
qed

lemma Vfrom_vsubset_VPow_Vfrom:
  assumes "Transset A"
  shows "Vfrom A i ⊆∘ VPow (Vfrom A i)"
  using assms Transset_VPow Transset_Vfrom by (auto simp: Transset_def)

lemma arg1_vsubset_VPow_Vfrom:
  assumes "Transset A"
  shows "A ⊆∘ VPow (Vfrom A i)"
  by (meson assms Vfrom_vsubset_VPow_Vfrom arg1_vsubset_Vfrom dual_order.trans)



subsection‹Operations closed with respect to const‹Vset››


text‹Empty set.›

lemma Limit_vempty_in_VsetI:
  assumes "Limit α"
  shows "0 ∈∘ Vset α"
  using assms by (auto simp: Limit_def)


text‹Subset.›

lemma vsubset_in_VsetI[intro]:
  assumes "a ⊆∘ A" and "A ∈∘ Vset i" 
  shows "a ∈∘ Vset i"
  using assms by (auto dest: VPow_vsubset_Vset)

lemma Ord_vsubset_in_Vset_succI:
  assumes "Ord α" and "A ⊆∘ Vset α"
  shows "A ∈∘ Vset (succ α)"
  using assms Ord_Vset_in_Vset_succI by auto


text‹Power set.›

lemma Limit_VPow_in_VsetI[intro]:
  assumes "Limit α" and "A ∈∘ Vset α" 
  shows "VPow A ∈∘ Vset α"
proof-
  from assms(1) have "Ord α" by auto
  with assms obtain i where "A ∈∘ Vset i" and "i ∈∘ α" and "Ord i"
    by (fastforce simp: Ord_in_Ord Limit_Vfrom_eq)
  have "Vset i ∈∘ Vset α" by (rule Vset_in_mono) (auto intro: ‹i ∈∘ α›)
  from VPow_vsubset_Vset[OF ‹A ∈∘ Vset i›] this show ?thesis
    by (rule vsubset_in_VsetI)
qed

lemma VPow_in_Vset_revD:
  assumes "VPow A ∈∘ Vset i"
  shows "A ∈∘ Vset i"
  using assms Vset_trans by blast

lemma Ord_VPow_in_Vset_succI:
  assumes "Ord α" and "a ∈∘ Vset α"
  shows "VPow a ∈∘ Vset (succ α)"
  using VPow_vsubset_Vset[OF assms(2)] 
  by (auto intro: Ord_Vset_in_Vset_succI[OF assms(1)])

lemma Ord_VPow_in_Vset_succD:
  assumes "Ord α" and "VPow a ∈∘ Vset (succ α)"
  shows "a ∈∘ Vset α"
  using assms by (fastforce dest: Vset_succ)


text‹Union of elements.›

lemma VUnion_in_VsetI[intro]:
  assumes "A ∈∘ Vset i"
  shows "⋃∘A ∈∘ Vset i"
proof-
  define i' where "i' = rank i"
  note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
  from rank_conv(2) assms show ?thesis 
    unfolding rank_conv
  proof induction
    case (succ α)
    show "⋃∘A ∈∘ Vset (succ α)"
      by (metis succ(1,3) VPow_iff VUnion_least Vset_trans Vset_succ)
  qed (auto simp: vrange_VLambda vimage_VLambda_vrange_rep Limit_Vfrom_eq)
qed

lemma Limit_VUnion_in_VsetD:
  assumes "Limit α" and "⋃∘A ∈∘ Vset α"
  shows "A ∈∘ Vset α"
proof-
  have "A ⊆∘ VPow (⋃∘A)" by auto
  moreover from assms have "VPow (⋃∘A) ∈∘ Vset α" by (rule Limit_VPow_in_VsetI)
  ultimately show ?thesis using assms(1) by auto
qed


text‹Intersection of elements.›

lemma VInter_in_VsetI[intro]:
  assumes "A ∈∘ Vset α"
  shows "⋂∘A ∈∘ Vset α"
proof-
  have subset: "⋂∘A ⊆∘ ⋃∘A" by auto
  moreover from assms have "⋃∘A ∈∘ Vset α" by (rule VUnion_in_VsetI)
  ultimately show ?thesis by (rule vsubset_in_VsetI)
qed


text‹Singleton.›

lemma Limit_vsingleton_in_VsetI[intro]:
  assumes "Limit α" and "a ∈∘ Vset α"
  shows "set {a} ∈∘ Vset α"
proof-
  have aa: "set {a} ⊆∘ VPow a" by auto
  from assms(1) have "Ord α" by auto
  from vsubset_in_VsetI[OF aa Limit_VPow_in_VsetI[OF assms(1)]] show ?thesis
    by (simp add: Limit_is_Ord assms(2))
qed

lemma Limit_vsingleton_in_VsetD:
  assumes "set {a} ∈∘ Vset α"
  shows "a ∈∘ Vset α"
  using assms by auto

lemma Ord_vsingleton_in_Vset_succI:
  assumes "Ord α" and "a ∈∘ Vset α"
  shows "set {a} ∈∘ Vset (succ α)"
  using assms by (simp add: Vset_succ vsubset_vsingleton_leftI)


text‹Doubleton.›

lemma Limit_vdoubleton_in_VsetI[intro]:
  assumes "Limit α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "set {a, b} ∈∘ Vset α"
proof-
  from assms(1) have "Ord α" by auto
  from assms have "a ∈∘ (⋃∘ξ∈∘α. Vset ξ)" and "b ∈∘ (⋃∘ξ∈∘α. Vset ξ)" 
    by (simp_all add: SUP_vifunion[symmetric] Limit_Vfrom_eq)
  then obtain A B 
    where a: "a ∈∘ Vset A" and "A ∈∘ α" and b: "b ∈∘ Vset B" and "B ∈∘ α"
    by blast
  moreover with assms have "Ord A" and "Ord B" by auto
  ultimately have "A ∪∘ B ∈∘ α" 
    by (metis Ord_linear_le le_iff_sup sup.order_iff)
  then have "Vset (A ∪∘ B) ∈∘ Vset α" 
    by (simp add: assms Limit_is_Ord Vset_in_mono)
  moreover from a b have "set {a, b} ⊆∘ Vset (A ∪∘ B)" 
    by (simp add: Vfrom_sup vsubset_vdoubleton_leftI)
  ultimately show "set {a, b} ∈∘ Vset α" by (rule vsubset_in_VsetI[rotated 1])
qed

lemma vdoubleton_in_VsetD:
  assumes "set {a, b} ∈∘ Vset α"
  shows "a ∈∘ Vset α" and "b ∈∘ Vset α"
  using assms by (auto intro!: Vset_trans[of _ ‹set {a, b}›])

lemma Ord_vdoubleton_in_Vset_succI:
  assumes "Ord α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "set {a, b} ∈∘ Vset (succ α)"
  by 
    (
      meson 
        assms Ord_Vset_in_Vset_succI vsubset_in_VsetI vsubset_vdoubleton_leftI
    )


text‹Pairwise union.›

lemma vunion_in_VsetI[intro]:
  assumes "a ∈∘ Vset i" and "b ∈∘ Vset i"
  shows "a ∪∘ b ∈∘ Vset i"
proof-
  define i' where "i' = rank i"
  note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
  show ?thesis 
    using rank_conv(2) assms unfolding rank_conv
  proof induction
    case (Limit α)
    from Limit have "set {a, b} ∈∘ Vset α"  
      by (intro Limit_vdoubleton_in_VsetI; unfold SUP_vifunion[symmetric]) 
        simp_all
    then have "⋃∘(set {a, b}) ∈∘ Vset α" by (blast intro: Limit.hyps)
    with Limit.hyps VUnion_vdoubleton have "a ∪∘ b ∈∘ (⋃∘ξ∈∘α. Vset ξ)"
      by (auto simp: Limit_Vfrom_eq)
    then show "a ∪∘ b ∈∘ Vset (⋃∘ξ∈∘α. ξ)" 
      by (simp add: ‹Limit α› Limit_Vfrom_eq)
  qed (auto simp add: Vset_succ)
qed

lemma vunion_in_VsetD:
  assumes "a ∪∘ b ∈∘ Vset α"
  shows "a ∈∘ Vset α" and "b ∈∘ Vset α"
  using assms by (meson vsubset_in_VsetI inf_sup_ord(3,4))+


text‹Pairwise intersection.›

lemma vintersection_in_VsetI[intro]:
  assumes "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "a ∩∘ b ∈∘ Vset α"
  using assms by (meson vsubset_in_VsetI inf_sup_ord(2))


text‹Set difference.›

lemma vdiff_in_VsetI[intro]:
  assumes "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "a -∘ b ∈∘ Vset α"
  using assms by auto


text‹const‹vinsert›.›

lemma vinsert_in_VsetI[intro]:
  assumes "Limit α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "vinsert a b ∈∘ Vset α"
proof-
  have ab: "vinsert a b = set {a} ∪∘ b" by simp
  from assms(2) have "set {a} ∈∘ Vset α"
    by (simp add: Limit_vsingleton_in_VsetI assms(1))
  from this assms(1,3) show "vinsert a b ∈∘ Vset α"
    unfolding ab by blast
qed

lemma vinsert_in_Vset_succI[intro]:
  assumes "Ord α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "vinsert a b ∈∘ Vset (succ α)"
  using assms by blast

lemma vinsert_in_Vset_succI'[intro]:
  assumes "Ord α" and "a ∈∘ Vset α" and "b ∈∘ Vset (succ α)"
  shows "vinsert a b ∈∘ Vset (succ α)"
proof-
  have ab: "vinsert a b = set {a} ∪∘ b" by simp
  show ?thesis
    unfolding ab by (intro vunion_in_VsetI Ord_vsingleton_in_Vset_succI assms)
qed

lemma vinsert_in_VsetD:
  assumes "vinsert a b ∈∘ Vset α"
  shows "a ∈∘ Vset α" and "b ∈∘ Vset α"
  using assms Vset_trans by blast+

lemma Limit_insert_in_VsetI:
  assumes [intro]: "Limit α" 
    and [simp]: "small x" 
    and "set x ∈∘ Vset α"
    and [intro]: "a ∈∘ Vset α"
  shows "set (insert a x) ∈∘ Vset α"
proof-
  have ax: "set (insert a x) = vinsert a (set x)" by auto
  from assms show ?thesis unfolding ax by auto
qed


text‹Pair.›

lemma Limit_vpair_in_VsetI[intro]:
  assumes "Limit α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "⟨a, b⟩ ∈∘ Vset α"
  using assms Limit_vdoubleton_in_VsetI Limit_vsingleton_in_VsetI 
  unfolding vpair_def
  by simp

lemma vpair_in_VsetD[intro]:
  assumes "⟨a, b⟩ ∈∘ Vset α"
  shows "a ∈∘ Vset α" and "b ∈∘ Vset α"
  using assms unfolding vpair_def by (meson vdoubleton_in_VsetD)+


text‹Cartesian product.›

lemma Limit_vtimes_in_VsetI[intro]:  
  assumes "Limit α" and "A ∈∘ Vset α" and "B ∈∘ Vset α"
  shows "A ×∘ B ∈∘ Vset α"
proof-
  from assms(1) have "Ord α" by auto
  have "VPow (VPow (A ∪∘ B)) ∈∘ Vset α"
    by (simp add: assms Limit_VPow_in_VsetI Limit_is_Ord vunion_in_VsetI)
  from assms(1) vsubset_in_VsetI[OF vtimes_vsubset_VPowVPow this] show ?thesis 
    by auto
qed


text‹Binary relations.›

lemma (in vbrelation) vbrelation_Limit_in_VsetI[intro]: 
  assumes "Limit α" and "𝒟∘ r ∈∘ Vset α" and "ℛ∘ r ∈∘ Vset α"
  shows "r ∈∘ Vset α"  
  using assms vdomain_vrange_vtimes by auto

lemma 
  assumes "r ∈∘ Vset α"
  shows vdomain_in_VsetI: "𝒟∘ r ∈∘ Vset α" 
    and vrange_in_VsetI: "ℛ∘ r ∈∘ Vset α" 
    and vfield_in_VsetI: "ℱ∘ r ∈∘ Vset α"
proof-
  from assms have "⋃∘r ∈∘ Vset α" by auto
  with assms(1) have r: "⋃∘(⋃∘r) ∈∘ Vset α" by blast
  from r assms(1) vfield_vsubset_VUnion2 show "ℱ∘ r ∈∘ Vset α" by auto
  from r assms(1) vdomain_vsubset_VUnion2 vrange_vsubset_VUnion2 show 
    "𝒟∘ r ∈∘ Vset α" "ℛ∘ r ∈∘ Vset α"
    by auto
qed

lemma (in vbrelation) vbrelation_Limit_vsubset_VsetI:
  assumes "Limit α" and "𝒟∘ r ⊆∘ Vset α" and "ℛ∘ r ⊆∘ Vset α"
  shows "r ⊆∘ Vset α"
proof(intro vsubsetI)
  fix x assume "x ∈∘ r"
  moreover then obtain a b where x_def: "x = ⟨a, b⟩" by (elim vbrelation_vinE)
  ultimately have "a ∈∘ 𝒟∘ r" and "b ∈∘ ℛ∘ r" by auto
  with assms show "x ∈∘ Vset α" unfolding x_def by auto
qed

lemma 
  assumes "r ∈∘ Vset α"
  shows fdomain_in_VsetI: "𝒟∙ r ∈∘ Vset α" 
    and frange_in_VsetI: "ℛ∙ r ∈∘ Vset α" 
    and ffield_in_VsetI: "ℱ∙ r ∈∘ Vset α"
proof-
  from assms have "⋃∘r ∈∘ Vset α" by auto
  with assms have r: "⋃∘(⋃∘(⋃∘r)) ∈∘ Vset α" by blast
  from r assms(1) fdomain_vsubset_VUnion2 frange_vsubset_VUnion2 show 
    "𝒟∙ r ∈∘ Vset α" "ℛ∙ r ∈∘ Vset α"
    by auto
  from r assms(1) ffield_vsubset_VUnion2 show "ℱ∙ r ∈∘ Vset α" by auto
qed

lemma (in vsv) vsv_Limit_vrange_in_VsetI[intro]: 
  assumes "Limit α" and "ℛ∘ r ⊆∘ Vset α" and "vfinite (𝒟∘ r)" 
  shows "ℛ∘ r ∈∘ Vset α"
  using assms(3,1,2) vsv_axioms
proof(induction ‹𝒟∘ r› arbitrary: r rule: vfinite_induct)
  case vempty
  interpret r': vsv r by (rule vempty(4))
  from vempty(1) r'.vlrestriction_vdomain have "r = 0" by simp
  from Vset_in_mono vempty.prems(1) show ?case 
    unfolding ‹r = 0› by (auto simp: Limit_def)
next
  case (vinsert x F)
  interpret r': vsv r by (rule vinsert(7))
  have RrF_Rr: "ℛ∘ (r ↾l∘ F) ⊆∘ ℛ∘ r" by auto
  have F_DrF: "F = 𝒟∘ (r ↾l∘ F)" 
    unfolding vdomain_vlrestriction vinsert(4)[symmetric] by auto
  moreover note assms(1)
  moreover from RrF_Rr vinsert(6) have "ℛ∘ (r ↾l∘ F) ⊆∘ Vset α" by auto
  moreover have "vsv (r ↾l∘ F)" by simp
  ultimately have RrF_Vα: "ℛ∘ (r ↾l∘ F) ∈∘ Vset α" by (rule vinsert(3))
  have "ℛ∘ r = vinsert (r⦇x⦈) (ℛ∘ (r ↾l∘ F))" 
  proof(intro vsubset_antisym vsubsetI)
    fix b assume "b ∈∘ ℛ∘ r"
    then obtain a where "a ∈∘ 𝒟∘ r" and b_def: "b = r⦇a⦈" by force
    with vinsert.hyps(4) have "a = x ∨ a ∈∘ F" by auto
    with ‹a ∈∘ 𝒟∘ r› show "b ∈∘ vinsert (r⦇x⦈) (ℛ∘ (r ↾l∘ F))"
      unfolding b_def by (blast dest: r'.vsv_vimageI1)
  next
    fix b assume "b ∈∘ vinsert (r⦇x⦈) (ℛ∘ (r ↾l∘ F))"
    with RrF_Rr r'.vsv_axioms vinsert.hyps(4) show "b ∈∘ ℛ∘ r" by auto
  qed
  moreover with vinsert.prems(2) have "r⦇x⦈ ∈∘ Vset α" by auto
  moreover have "ℛ∘ (r ↾l∘ F) ∈∘ Vset α" by (blast intro: RrF_Vα)
  ultimately show "ℛ∘ r ∈∘ Vset α" 
    by (simp add: vinsert.prems(1) vinsert_in_VsetI)
qed

lemma (in vsv) vsv_Limit_vsv_in_VsetI[intro]: 
  assumes "Limit α" 
    and "𝒟∘ r ∈∘ Vset α"
    and "ℛ∘ r ⊆∘ Vset α" 
    and "vfinite (𝒟∘ r)" 
  shows "r ∈∘ Vset α"
  by (simp add: assms vsv_Limit_vrange_in_VsetI vbrelation_Limit_in_VsetI)

lemma Limit_vcomp_in_VsetI:
  assumes "Limit α" and "r ∈∘ Vset α" and "s ∈∘ Vset α"
  shows "r ∘∘ s ∈∘ Vset α"
proof(rule vbrelation.vbrelation_Limit_in_VsetI; (intro assms(1))?)
  show "vbrelation (r ∘∘ s)" by auto
  have "𝒟∘ (r ∘∘ s) ⊆∘ 𝒟∘ s" by auto
  with assms(3) show "𝒟∘ (r ∘∘ s) ∈∘ Vset α"  
    by (auto simp: vdomain_in_VsetI vsubset_in_VsetI)
  have "ℛ∘ (r ∘∘ s) ⊆∘ ℛ∘ r" by auto
  with assms(2) show "ℛ∘ (r ∘∘ s) ∈∘ Vset α"
    by (auto simp: vrange_in_VsetI vsubset_in_VsetI)
qed


text‹Operations on indexed families of sets.›

lemma Limit_vifintersection_in_VsetI:
  assumes "Limit α" and "⋀i. i ∈∘ I ⟹ A i ∈∘ Vset α" and "vfinite I"
  shows "(⋂∘i∈∘I. A i) ∈∘ Vset α"
proof-
  from assms(2) have range: "ℛ∘ (λi∈∘I. A i) ⊆∘ Vset α" by auto
  from assms(1) range assms(3) have "ℛ∘ (λi∈∘I. A i) ∈∘ Vset α"
    by (rule rel_VLambda.vsv_Limit_vrange_in_VsetI[unfolded vdomain_VLambda])
  then have "(λi∈∘I. A i) `∘ I ∈∘ Vset α" 
    by (simp add: vimage_VLambda_vrange_rep)
  then show "(⋂∘i∈∘I. A i) ∈∘ Vset α" by auto
qed

lemma Limit_vifunion_in_VsetI:
  assumes "Limit α" and "⋀i. i ∈∘ I ⟹ A i ∈∘ Vset α" and "vfinite I"
  shows "(⋃∘i∈∘I. A i) ∈∘ Vset α"
proof-
  from assms(2) have range: "ℛ∘ (λi∈∘I. A i) ⊆∘ Vset α" by auto
  from assms(1) range assms(3) have "ℛ∘ (λi∈∘I. A i) ∈∘ Vset α"
    by (rule rel_VLambda.vsv_Limit_vrange_in_VsetI[unfolded vdomain_VLambda])
  then have "(λi∈∘I. A i) `∘ I ∈∘ Vset α" 
    by (simp add: vimage_VLambda_vrange_rep)
  then show "(⋃∘i∈∘I. A i) ∈∘ Vset α" by auto
qed

lemma Limit_vifunion_in_Vset_if_VLambda_in_VsetI:
  assumes "Limit α" and "VLambda I A ∈∘ Vset α"
  shows "(⋃∘i∈∘I. A i) ∈∘ Vset α"
proof-
  from assms(2) have "ℛ∘ (λi∈∘I. A i) ∈∘ Vset α"
    by (simp add: vrange_in_VsetI)
  then have "(λi∈∘I. A i) `∘ I ∈∘ Vset α" 
    by (simp add: vimage_VLambda_vrange_rep)
  then show "(⋃∘i∈∘I. A i) ∈∘ Vset α" by auto
qed

lemma Limit_vproduct_in_VsetI:
  assumes "Limit α" 
    and "I ∈∘ Vset α" 
    and "⋀i. i ∈∘ I ⟹ A i ∈∘ Vset α" 
    and "vfinite I"
  shows "(∏∘i∈∘I. A i) ∈∘ Vset α"
proof-
  have "(⋃∘i∈∘I. A i) ∈∘ Vset α"
    by (rule Limit_vifunion_in_VsetI) (simp_all add: assms(1,3,4))
  with assms have "I ×∘ (⋃∘i∈∘I. A i) ∈∘ Vset α" by auto
  with assms(1) have "VPow (I ×∘ (⋃∘i∈∘I. A i)) ∈∘ Vset α" by auto
  from vsubset_in_VsetI[OF vproduct_vsubset_VPow[of I A] this] show ?thesis 
    by simp
qed

lemma Limit_vproduct_in_Vset_if_VLambda_in_VsetI:
  assumes "Limit α" and "VLambda I A ∈∘ Vset α"
  shows "(∏∘i∈∘I. A i) ∈∘ Vset α"
proof-
  have "(⋃∘i∈∘I. A i) ∈∘ Vset α"
    by (rule Limit_vifunion_in_Vset_if_VLambda_in_VsetI) 
      (simp_all add: assms)
  moreover from assms(2) have "I ∈∘ Vset α"
    by (metis vdomain_VLambda vdomain_in_VsetI)
  ultimately have "I ×∘ (⋃∘i∈∘I. A i) ∈∘ Vset α" 
    using assms by auto
  with assms(1) have "VPow (I ×∘ (⋃∘i∈∘I. A i)) ∈∘ Vset α" by auto
  from vsubset_in_VsetI[OF vproduct_vsubset_VPow[of I A] this] show ?thesis 
    by simp  
qed

lemma vrange_vprojection_in_VsetI:
  assumes "Limit α" 
    and "A ∈∘ Vset α" 
    and "⋀f. f ∈∘ A ⟹ vsv f"
    and "⋀f. f ∈∘ A ⟹ x ∈∘ 𝒟∘ f"
  shows "ℛ∘ (λf∈∘A. f⦇x⦈) ∈∘ Vset α"
proof-
  have "ℛ∘ (λf∈∘A. f⦇x⦈) ⊆∘ ⋃∘(⋃∘(⋃∘A))"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ (λf∈∘A. f⦇x⦈)"
    then obtain f where f: "f ∈∘ A" and y_def: "y = f⦇x⦈" by auto
    from f have "vsv f" and "x ∈∘ 𝒟∘ f" by (auto intro: assms(3,4))+
    with y_def have xy: "⟨x, y⟩ ∈∘ f" by auto
    show "y ∈∘ ⋃∘(⋃∘(⋃∘A))"
    proof(intro VUnionI)
      show "f ∈∘ A" by (rule f)
      show "⟨x, y⟩ ∈∘ f" by (rule xy)
      show "set {x, y} ∈∘ ⟨x, y⟩" unfolding vpair_def by simp
    qed auto
  qed
  moreover from assms(1,2) have "⋃∘(⋃∘(⋃∘A)) ∈∘ Vset α"
    by (intro VUnion_in_VsetI)
  ultimately show ?thesis by auto
qed

lemma Limit_vcpower_in_VsetI:
  assumes "Limit α" and "n ∈∘ Vset α" and "A ∈∘ Vset α" and "vfinite n"
  shows "A ^× n ∈∘ Vset α"
  using assms Limit_vproduct_in_VsetI unfolding vcpower_def by auto


text‹Finite sets.›

lemma Limit_vfinite_in_VsetI:
  assumes "Limit α" and "A ⊆∘ Vset α" and "vfinite A"
  shows "A ∈∘ Vset α"
proof-
  from assms(3) obtain n where n: "n ∈∘ ω" and "n ≈∘ A" by clarsimp
  then obtain f where f: "v11 f" and dr: "𝒟∘ f = n" "ℛ∘ f = A" by auto
  interpret f: v11 f by (rule f)
  from n have n: "vfinite n" by auto
  show ?thesis 
    by (rule f.vsv_Limit_vrange_in_VsetI[simplified dr, OF assms(1,2) n])
qed


text‹Ordinal numbers.›

lemma Limit_omega_in_VsetI:
  assumes "Limit α"
  shows "aℕ ∈∘ Vset α"
proof-
  from assms have "α ⊆∘ Vset α" by force
  moreover have "ω ⊆∘ α" by (simp add: assms omega_le_Limit)
  moreover have "aℕ ∈∘ ω" by simp
  ultimately show "aℕ ∈∘ Vset α" by auto
qed

lemma Limit_succ_in_VsetI:
  assumes "Limit α" and "a ∈∘ Vset α"
  shows "succ a ∈∘ Vset α"
  by (simp add: assms succ_def vinsert_in_VsetI)


text‹Sequences.›

lemma (in vfsequence) vfsequence_Limit_vcons_in_VsetI:
  assumes "Limit α" and "x ∈∘ Vset α" and "xs ∈∘ Vset α"
  shows "vcons xs x ∈∘ Vset α"
  unfolding vcons_def
proof(intro vinsert_in_VsetI Limit_vpair_in_VsetI assms)
  show "vcard xs ∈∘ Vset α" 
    by (metis assms(3) vdomain_in_VsetI vfsequence_vdomain)
qed


text‹‹ftimes›.›

lemma Limit_ftimes_in_VsetI: 
  assumes "Limit α" and "A ∈∘ Vset α" and "B ∈∘ Vset α"
  shows "A ×∙ B ∈∘ Vset α"
    unfolding ftimes_def
proof(rule Limit_vproduct_in_VsetI)
  from assms(1) show "2ℕ ∈∘ Vset α" by (meson Limit_omega_in_VsetI)
  fix i assume "i ∈∘ 2ℕ"
  with assms(2,3) show "(i = 0 ? A : B) ∈∘ Vset α" by simp
qed (auto simp: assms(1))


text‹Auxiliary results.›

lemma vempty_in_Vset_succ[simp, intro]: "0 ∈∘ Vfrom a (succ b)"
  unfolding Vfrom_succ by force

lemma Ord_vpair_in_Vset_succI[intro]:
  assumes "Ord α" and "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "⟨a, b⟩ ∈∘ Vset (succ (succ α))"
  unfolding vpair_def
proof-
  have aab: "set {set {a}, set {a, b}} = vinsert (set {a}) (set {set {a, b}})"
    by auto
  show "set {set {a}, set {a, b}} ∈∘ Vset (succ (succ α))"
    unfolding aab
    by 
      (
        intro
          assms
          vinsert_in_Vset_succI'
          Ord_vsingleton_in_Vset_succI 
          Ord_vdoubleton_in_Vset_succI 
          Ord_succ
      ) 
qed

lemma Limit_vifunion_vsubset_VsetI:
  assumes "Limit α" and "⋀i. i ∈∘ I ⟹ A i ∈∘ Vset α"
  shows "(⋃∘i∈∘I. A i) ⊆∘ Vset α"
proof(intro vsubsetI)
  fix x assume "x ∈∘ (⋃∘i∈∘I. A i)"
  then obtain i where i: "i ∈∘ I" and "x ∈∘ A i" by auto
  with assms(1) assms(2)[OF i] show "x ∈∘ Vset α" by auto
qed

lemma Limit_vproduct_vsubset_Vset_succI:
  assumes "Limit α" and "I ∈∘ Vset α" and "⋀i. i ∈∘ I ⟹ A i ⊆∘ Vset α"
  shows "(∏∘i∈∘I. A i) ⊆∘ Vset (succ α)"
proof(intro vsubsetI)
  fix a assume prems: "a ∈∘ (∏∘i∈∘I. A i)"
  note a = vproductD[OF prems]
  interpret vsv a by (rule a(1))
  from prems have "ℛ∘ a ⊆∘ (⋃∘i∈∘I. A i)" by (rule vproduct_vrange)  
  moreover have "(⋃∘i∈∘I. A i) ⊆∘ Vset α" by (intro vifunion_least assms(3))
  ultimately have "ℛ∘ a ⊆∘ Vset α" by auto
  moreover from assms(2) prems have "𝒟∘ a ⊆∘ Vset α" unfolding a(2) by auto
  ultimately have "a ⊆∘ Vset α"
    by (intro assms(1) vbrelation_Limit_vsubset_VsetI)
  with assms(1) show "a ∈∘ Vset (succ α)"
    by (simp add: Limit_is_Ord Ord_vsubset_in_Vset_succI)
qed

lemma Limit_vproduct_vsubset_Vset_succI':
  assumes "Limit α" and "I ∈∘ Vset α" and "⋀i. i ∈∘ I ⟹ A i ∈∘ Vset α"
  shows "(∏∘i∈∘I. A i) ⊆∘ Vset (succ α)"
proof-
  have "A i ⊆∘ Vset α" if "i ∈∘ I" for i
    by (simp add: Vset_trans vsubsetI assms(3) that)
  from assms(1,2) this show ?thesis by (rule Limit_vproduct_vsubset_Vset_succI)
qed

lemma (in vfsequence) vfsequence_Ord_vcons_in_Vset_succI: 
  assumes "Ord α"
    and "ω ∈∘ α"
    and "x ∈∘ Vset α"
    and "xs ∈∘ Vset (succ (succ (succ α)))"
  shows "vcons xs x ∈∘ Vset (succ (succ (succ α)))"
  unfolding vcons_def
proof(intro vinsert_in_Vset_succI' Ord_succ Ord_vpair_in_Vset_succI assms)
  have "vcard xs = 𝒟∘ xs" by (simp add: vfsequence_vdomain)
  from assms(1,2) vfsequence_vdomain_in_omega show "vcard xs ∈∘ Vset α" 
    unfolding vfsequence_vdomain[symmetric]
    by (meson Ord_in_in_VsetI Vset_trans)
qed

lemma Limit_VUnion_vdomain_in_VsetI:
  assumes "Limit α" and "Q ∈∘ Vset α"
  shows "(⋃∘r∈∘Q. 𝒟∘ r) ∈∘ Vset α"
proof-
  have "(⋃∘r∈∘Q. 𝒟∘ r) ⊆∘ ⋃∘(⋃∘(⋃∘Q))"
  proof(intro vsubsetI)
    fix a assume "a ∈∘ (⋃∘r∈∘Q. 𝒟∘ r)"
    then obtain r where r: "r ∈∘ Q" and "a ∈∘ 𝒟∘ r" by auto
    with assms obtain b where ab: "⟨a, b⟩ ∈∘ r" by auto
    show "a ∈∘ ⋃∘(⋃∘(⋃∘Q))"
    proof(intro VUnionI)
      show "r ∈∘ Q" by (rule r)  
      show "⟨a, b⟩ ∈∘ r" by (rule ab)
      show "set {a, b} ∈∘ ⟨a, b⟩" unfolding vpair_def by simp
    qed auto
  qed
  moreover from assms(2) have "⋃∘(⋃∘(⋃∘Q)) ∈∘ Vset α"
    by (blast dest!: VUnion_in_VsetI)
  ultimately show ?thesis using assms(1) by (auto simp: vsubset_in_VsetI)
qed

lemma Limit_VUnion_vrange_in_VsetI:
  assumes "Limit α" and "Q ∈∘ Vset α"
  shows "(⋃∘r∈∘Q. ℛ∘ r) ∈∘ Vset α"
proof-(*FIXME: duality*)
  have "(⋃∘r∈∘Q. ℛ∘ r) ⊆∘ ⋃∘(⋃∘(⋃∘Q))"
  proof(intro vsubsetI)
    fix b assume "b ∈∘ (⋃∘r∈∘Q. ℛ∘ r)"
    then obtain r where r: "r ∈∘ Q" and "b ∈∘ ℛ∘ r" by auto
    with assms obtain a where ab: "⟨a, b⟩ ∈∘ r" by auto
    show "b ∈∘ ⋃∘(⋃∘(⋃∘Q))"
    proof(intro VUnionI)
      show "r ∈∘ Q" by (rule r)  
      show "⟨a, b⟩ ∈∘ r" by (rule ab)
      show "set {a, b} ∈∘ ⟨a, b⟩" unfolding vpair_def by simp
    qed auto
  qed
  moreover from assms(2) have "⋃∘(⋃∘(⋃∘Q)) ∈∘ Vset α"
    by (blast dest!: VUnion_in_VsetI)
  ultimately show ?thesis using assms(1) by (auto simp: vsubset_in_VsetI)
qed



subsection‹Axioms for term‹Vset α››


text‹
The subsection demonstrates that the axioms of ZFC except for the 
Axiom Schema of Replacement hold in term‹Vset α› for any limit ordinal
term‹α› such that term‹ω ∈∘ α›\footnote{The presentation of the axioms is 
loosely based on the statement of the axioms of ZFC in Chapters 1-11 in 
\cite{takeuti_introduction_1971}.}.
›

locale 𝒵 = 
  fixes α 
  assumes Limit_α[intro, simp]: "Limit α"
    and omega_in_α[intro, simp]: "ω ∈∘ α"
begin

lemmas [intro] = 𝒵_axioms

lemma vempty_Z_def: "0 = set {x. x ≠ x}" by auto

lemma vempty_is_zet[intro, simp]: "0 ∈∘ Vset α" 
  using Vset_in_mono omega_in_α by auto

lemma Axiom_of_Extensionality:
  assumes "a ∈∘ Vset α" and "x = y" and "x ∈∘ a" 
  shows "y ∈∘ a" and "x ∈∘ Vset α" and "y ∈∘ Vset α"
  using assms by (simp_all add: Vset_trans)

lemma Axiom_of_Pairing:
  assumes "a ∈∘ Vset α" and "b ∈∘ Vset α"
  shows "set {a, b} ∈∘ Vset α"
  using assms by (simp add: Limit_vdoubleton_in_VsetI)

lemma Axiom_of_Unions:
  assumes "a ∈∘ Vset α"
  shows "⋃∘a ∈∘ Vset α"
  using assms by (simp add: VUnion_in_VsetI)

lemma Axiom_of_Powers:
  assumes "a ∈∘ Vset α"
  shows "VPow a ∈∘ Vset α"
  using assms by (simp add: Limit_VPow_in_VsetI)

lemma Axiom_of_Regularity:
  assumes "a ≠ 0" and "a ∈∘ Vset α"
  obtains x where "x ∈∘ a" and "x ∩∘ a = 0"
  using assms by (auto dest: trad_foundation)

lemma Axiom_of_Infinity: "ω ∈∘ Vset α"
  using Limit_is_Ord by (auto simp: Ord_iff_rank Ord_VsetI OrdmemD)

lemma Axiom_of_Choice: 
  assumes "A ∈∘ Vset α"
  obtains f where "f ∈∘ Vset α" and "⋀x. x ∈∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈∘ x"
proof-
  define f where "f = (λx∈∘A. (SOME a. a ∈∘ x ∨ (x = 0 ∧ a = 0)))"
  interpret vsv f unfolding f_def by auto
  have A_def: "A = 𝒟∘ f" unfolding f_def by simp
  have Rf: "ℛ∘ f ⊆∘ vinsert 0 (⋃∘A)"
  proof(rule vsubsetI)
    fix y assume "y ∈∘ ℛ∘ f" 
    then obtain x where "x ∈∘ A" and "y = f⦇x⦈" 
      unfolding A_def by (blast dest: vrange_atD)
    then have y_def: "y = (SOME a. a ∈∘ x ∨ x = 0 ∧ a = 0)"
      unfolding f_def unfolding A_def by simp
    have "y = 0 ∨ y ∈∘ x"
    proof(cases ‹x = 0›)
      case False then show ?thesis 
        unfolding y_def by (metis (mono_tags, lifting) verit_sko_ex' vemptyE)
    qed (simp add: y_def)
    with ‹x ∈∘ A› show "y ∈∘ vinsert 0 (⋃∘A)" by clarsimp
  qed
  from assms have "⋃∘A ∈∘ Vset α" by (simp add: Axiom_of_Unions)
  with vempty_is_zet Limit_α have "vinsert 0 (⋃∘A) ∈∘ Vset α" by auto
  with Rf have "ℛ∘ f ∈∘ Vset α" by auto
  with Limit_α assms[unfolded A_def] have "f ∈∘ Vset α" by auto
  moreover have "x ∈∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈∘ x" for x
  proof-
    assume prems: "x ∈∘ A" "x ≠ 0"
    then have "f⦇x⦈ = (SOME a. a ∈∘ x ∨ (x = 0 ∧ a = 0))"
      unfolding f_def by simp
    with prems(2) show "f⦇x⦈ ∈∘ x"
      by (metis (mono_tags, lifting) someI_ex vemptyE)
  qed
  ultimately show ?thesis by (simp add: that)
qed

end


text‹Trivial corollaries.›

lemma (in 𝒵) Ord_α: "Ord α" by auto

lemma (in 𝒵) 𝒵_Vset_ω2_vsubset_Vset: "Vset (ω + ω) ⊆∘ Vset α" 
  by (simp add: Vset_vsubset_mono omega2_vsubset_Limit)

lemma (in 𝒵) 𝒵_Limit_αω: "Limit (α + ω)" by (simp add: Limit_is_Ord)

lemma (in 𝒵) 𝒵_α_αω: "α ∈∘ α + ω" 
  by (simp add: Limit_is_Ord Ord_mem_iff_lt)

lemma (in 𝒵) 𝒵_ω_αω: "ω ∈∘ α + ω" 
  using add_le_cancel_left0 by blast

lemma 𝒵_ωω: "𝒵 (ω + ω)"
  using ω_gt0 by (auto intro: 𝒵.intro simp: Ord_mem_iff_lt)

lemma (in 𝒵) in_omega_in_omega_plus[intro]:
  assumes "a ∈∘ ω"
  shows "a ∈∘ Vset (α + ω)"
proof-
  from assms have "a ∈∘ Vset ω" by auto
  moreover have "Vset ω ∈∘ Vset (α + ω)" by (simp add: Vset_in_mono 𝒵_ω_αω)
  ultimately show "a ∈∘ Vset (α + ω)" by auto
qed

lemma (in 𝒵) ord_of_nat_in_Vset[simp]: "aℕ ∈∘ Vset α" by force



subsection‹Existence of a disjoint subset in term‹Vset α››

definition mk_doubleton :: "V ⇒ V ⇒ V"
  where "mk_doubleton X a = set {a, X}"

definition mk_doubleton_image :: "V ⇒ V ⇒ V"
  where "mk_doubleton_image X Y = set (mk_doubleton Y ` elts X)"

lemma inj_on_mk_doubleton: "inj_on (mk_doubleton X) (elts X)"
proof
  fix a b assume "mk_doubleton X a = mk_doubleton X b" 
  then have "{a, X} = {b, X}" unfolding mk_doubleton_def by auto
  then show "a = b" by (metis doubleton_eq_iff)
qed

lemma mk_doubleton_image_vsubset_veqpoll: 
  assumes "X ⊆∘ Y"
  shows "mk_doubleton_image X X ≈∘ mk_doubleton_image X Y"
  unfolding eqpoll_def
proof(intro exI[of _ ‹λA. vinsert Y (A -∘ set {X})›] bij_betw_imageI)
  show "inj_on (λA. vinsert Y (A -∘ set {X})) (elts (mk_doubleton_image X X))"
    unfolding mk_doubleton_image_def
  proof(intro inj_onI)
    fix y y' assume prems: 
      "y ∈∘ set (mk_doubleton X ` elts X)" 
      "y' ∈∘ set (mk_doubleton X ` elts X)" 
      "vinsert Y (y -∘ set {X}) = vinsert Y (y' -∘ set {X})" 
    then obtain x x' 
      where "x ∈∘ X" 
        and "x' ∈∘ X" 
        and y_def: "y = set {x, X}" 
        and y'_def: "y' = set {x', X}"
      by (clarsimp simp: mk_doubleton_def)
    with assms have xX_X: "set {x, X} -∘ set {X} = set {x}" 
      and x'X_X: "set {x', X} -∘ set {X} = set {x'}"
      by fastforce+
    from prems(3)[unfolded y_def y'_def] have "set {x, Y} = set {x', Y}"
      unfolding xX_X x'X_X by auto
    then have "x = x'" by (auto simp: doubleton_eq_iff)
    then show "y = y'" unfolding y_def y'_def by simp
  qed
  show 
    "(λA. vinsert Y (A -∘ set {X})) ` (elts (mk_doubleton_image X X)) = 
      (elts (mk_doubleton_image X Y))"
  proof(intro subset_antisym subsetI)
    fix z
    assume prems:
      "z ∈ (λA. vinsert Y (A -∘ set {X})) ` (elts (mk_doubleton_image X X))"
    then obtain y 
      where "y ∈∘ set (mk_doubleton X ` elts X)"
        and z_def: "z = vinsert Y (y -∘ set {X})"
      unfolding mk_doubleton_image_def by auto
    then obtain x where xX: "x ∈∘ X" and y_def: "y = set {x, X}" 
      unfolding mk_doubleton_def by clarsimp
    from xX have y_X: "y -∘ set {X} = set {x}" unfolding y_def by fastforce
    from z_def have z_def': "z = set {x, Y}"
      unfolding y_X by (simp add: doubleton_eq_iff vinsert_vsingleton)
    from xX show "z ∈∘ mk_doubleton_image X Y"
      unfolding z_def' mk_doubleton_def mk_doubleton_image_def by simp
  next
    fix z assume prems: "z ∈∘ mk_doubleton_image X Y"
    then obtain x where xX: "x ∈∘ X" and z_def: "z = set {x, Y}" 
      unfolding mk_doubleton_def mk_doubleton_image_def by clarsimp
    from xX have xX_XX: "set {x, X} ∈∘ set (mk_doubleton X ` elts X)"
      unfolding mk_doubleton_def by simp
    from xX have xX_X: "set {x, X} -∘ set {X} = set {x}" by fastforce
    have z_def': "z = vinsert Y (set {x, X} -∘ set {X})"
      unfolding xX_X z_def by auto
    with xX_XX show 
      "z ∈ (λA. vinsert Y (A -∘ set {X})) ` (elts (mk_doubleton_image X X))"
      unfolding z_def' mk_doubleton_image_def by simp
  qed
qed

lemma mk_doubleton_image_veqpoll: 
  assumes "X ⊆∘ Y"
  shows "X ≈∘ mk_doubleton_image X Y"
proof-
  have "X ≈∘ mk_doubleton_image X X"
    unfolding mk_doubleton_image_def by (auto simp: inj_on_mk_doubleton)
  also have "… ≈ elts (mk_doubleton_image X Y)"
    by (rule mk_doubleton_image_vsubset_veqpoll[OF assms])
  finally show "X ≈∘ mk_doubleton_image X Y".
qed

lemma vdisjnt_mk_doubleton_image: "vdisjnt (mk_doubleton_image X Y) Y"
proof
  fix b assume prems: "b ∈∘ Y" "b ∈∘ mk_doubleton_image X Y" 
  then obtain a where "a ∈∘ X" and "set {a, Y} = b" 
    unfolding mk_doubleton_def mk_doubleton_image_def by clarsimp
  then have "Y ∈∘ b" by clarsimp
  with mem_not_sym show False by (simp add: prems)
qed

lemma Limit_mk_doubleton_image_vsubset_Vset: 
  assumes "Limit α" and "X ⊆∘ Y" and "Y ∈∘ Vset α"
  shows "mk_doubleton_image X Y ⊆∘ Vset α"
proof(intro vsubsetI)
  fix b assume "b ∈∘ mk_doubleton_image X Y"
  then obtain a where "b = mk_doubleton Y a" and "a ∈∘ X" 
    unfolding mk_doubleton_image_def by clarsimp
  with assms have b_def: "b = set {a, Y}" and aα: "a ∈∘ Vset α" 
    by (auto simp: mk_doubleton_def)
  from this(2) assms show "b ∈∘ Vset α"
    unfolding b_def by (simp add: Limit_vdoubleton_in_VsetI)
qed

lemma Ord_mk_doubleton_image_vsubset_Vset_succ: 
  assumes "Ord α" and "X ⊆∘ Y" and "Y ∈∘ Vset α"
  shows "mk_doubleton_image X Y ⊆∘ Vset (succ α)"
proof(intro vsubsetI)
  fix b assume "b ∈∘ mk_doubleton_image X Y"
  then obtain a where "b = mk_doubleton Y a" and "a ∈∘ X" 
    unfolding mk_doubleton_image_def by clarsimp
  with assms have b_def: "b = set {a, Y}" and aα: "a ∈∘ Vset α" 
    by (auto simp: mk_doubleton_def)
  from this(2) assms show "b ∈∘ Vset (succ α)"
    unfolding b_def by (simp add: Ord_vdoubleton_in_Vset_succI)
qed

lemma Limit_ex_eqpoll_vdisjnt:
  assumes "Limit α" and "X ⊆∘ Y" and "Y ∈∘ Vset α"
  obtains Z where "X ≈∘ Z" and "vdisjnt Z Y" and "Z ⊆∘ Vset α"
  using assms
  by (intro that[of ‹mk_doubleton_image X Y›])
    (
      simp_all add: 
        mk_doubleton_image_veqpoll 
        vdisjnt_mk_doubleton_image 
        Limit_mk_doubleton_image_vsubset_Vset
    )

lemma Ord_ex_eqpoll_vdisjnt:
  assumes "Ord α" and "X ⊆∘ Y" and "Y ∈∘ Vset α"
  obtains Z where "X ≈∘ Z" and "vdisjnt Z Y" and "Z ⊆∘ Vset (succ α)"
  using assms
  by (intro that[of ‹mk_doubleton_image X Y›])
    (
      simp_all add: 
        mk_doubleton_image_veqpoll 
        vdisjnt_mk_doubleton_image 
        Ord_mk_doubleton_image_vsubset_Vset_succ
    )

text‹\newpage›

end

Theory CZH_Sets_NOP

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹n›-ary operation›
theory CZH_Sets_NOP
  imports CZH_Sets_FBRelations
begin



subsection‹Partial ‹n›-ary operation›

locale pnop = vsv f for A n f :: V +
  assumes pnop_n: "n ∈∘ ω" 
    and pnop_vdomain: "𝒟∘ f ⊆∘ A ^× n"
    and pnop_vrange: "ℛ∘ f ⊆∘ A"


text‹Rules.›

lemma pnopI[intro]:
  assumes "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f ⊆∘ A ^× n"
    and "ℛ∘ f ⊆∘ A"
  shows "pnop A n f"
  using assms unfolding pnop_def pnop_axioms_def by blast

lemma pnopD[dest]:
  assumes "pnop A n f"
  shows "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f ⊆∘ A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms unfolding pnop_def pnop_axioms_def by blast+

lemma pnopE[elim]:
  assumes "pnop A n f"
  obtains "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f ⊆∘ A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms by force



subsection‹Total ‹n›-ary operation›

locale nop = vsv f for A n f :: V +
  assumes nop_n: "n ∈∘ ω" 
    and nop_vdomain: "𝒟∘ f = A ^× n"
    and nop_vrange: "ℛ∘ f ⊆∘ A"

sublocale nop ⊆ pnop A n f
proof(intro pnopI)
  show "vsv f" by (rule vsv_axioms)
  show "n ∈∘ ω" by (rule nop_n)
  from nop_vdomain show "𝒟∘ f ⊆∘ A ^× n" by simp
  show "ℛ∘ f ⊆∘ A" by (rule nop_vrange)
qed


text‹Rules.›

lemma nopI[intro]:
  assumes "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  shows "nop A n f"
  using assms unfolding nop_def nop_axioms_def by blast

lemma nopD[dest]:
  assumes "nop A n f"
  shows "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms unfolding nop_def nop_axioms_def by blast+

lemma nopE[elim]:
  assumes "nop A n f"
  obtains "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms by force



subsection‹Injective ‹n›-ary operation›

locale nop_v11 = v11 f for A n f :: V +
  assumes nop_v11_n: "n ∈∘ ω" 
    and nop_v11_vdomain: "𝒟∘ f = A ^× n"
    and nop_v11_vrange: "ℛ∘ f ⊆∘ A"

sublocale nop_v11 ⊆ nop 
proof
  show "vsv f" by (rule vsv_axioms)
  show "n ∈∘ ω" by (rule nop_v11_n)
  show "𝒟∘ f = A ^× n" by (rule nop_v11_vdomain)
  show "ℛ∘ f ⊆∘ A" by (rule nop_v11_vrange)
qed


text‹Rules.›

lemma nop_v11I[intro]:
  assumes "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  shows "nop_v11 A n f"
  using assms unfolding nop_v11_def nop_v11_axioms_def by blast

lemma nop_v11D[dest]:
  assumes "nop_v11 A n f"
  shows "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms unfolding nop_v11_def nop_v11_axioms_def by blast+

lemma nop_v11E[elim]:
  assumes "nop_v11 A n f"
  obtains "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f ⊆∘ A"
  using assms by force



subsection‹Surjective ‹n›-ary operation›

locale nop_onto = vsv f for A n f :: V +
  assumes nop_onto_n: "n ∈∘ ω" 
    and nop_onto_vdomain: "𝒟∘ f = A ^× n"
    and nop_onto_vrange: "ℛ∘ f = A"

sublocale nop_onto ⊆ nop 
proof
  show "vsv f" by (rule vsv_axioms)
  show "n ∈∘ ω" by (rule nop_onto_n)
  show "𝒟∘ f = A ^× n" by (rule nop_onto_vdomain)
  show "ℛ∘ f ⊆∘ A" by (simp add: nop_onto_vrange)
qed


text‹Rules.›

lemma nop_ontoI[intro]:
  assumes "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  shows "nop_onto A n f"
  using assms unfolding nop_onto_def nop_onto_axioms_def by blast

lemma nop_ontoD[dest]:
  assumes "nop_onto A n f"
  shows "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  using assms unfolding nop_onto_def nop_onto_axioms_def by auto

lemma nop_ontoE[elim]:
  assumes "nop_onto A n f"
  obtains "vsv f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  using assms by force



subsection‹Bijective ‹n›-ary operation›

locale nop_bij = v11 f for A n f :: V +
  assumes nop_bij_n: "n ∈∘ ω" 
    and nop_bij_vdomain: "𝒟∘ f = A ^× n"
    and nop_bij_vrange: "ℛ∘ f = A"

sublocale nop_bij ⊆ nop_v11 
proof
  show "v11 f" by (rule v11_axioms)
  show "n ∈∘ ω" by (rule nop_bij_n)
  show "𝒟∘ f = A ^× n" by (rule nop_bij_vdomain)
  show "ℛ∘ f ⊆∘ A" by (simp add: nop_bij_vrange)
qed

sublocale nop_bij ⊆ nop_onto 
proof
  show "vsv f" by (rule vsv_axioms)
  show "n ∈∘ ω" by (rule nop_bij_n)
  show "𝒟∘ f = A ^× n" by (rule nop_bij_vdomain)
  show "ℛ∘ f = A" by (rule nop_bij_vrange)
qed


text‹Rules.›

lemma nop_bijI[intro]:
  assumes "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  shows "nop_bij A n f"
  using assms unfolding nop_bij_def nop_bij_axioms_def by blast

lemma nop_bijD[dest]:
  assumes "nop_bij A n f"
  shows "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  using assms unfolding nop_bij_def nop_bij_axioms_def by auto

lemma nop_bijE[elim]:
  assumes "nop_bij A n f"
  obtains "v11 f"
    and "n ∈∘ ω"
    and "𝒟∘ f = A ^× n"
    and "ℛ∘ f = A"
  using assms by force



subsection‹Scalar›

locale scalar = 
  fixes A f
  assumes scalar_nop: "nop A 0 f"

sublocale scalar ⊆ nop A 0 f
  rewrites scalar_vdomain[simp]: "A ^× 0 = set {0}"
  by (auto simp: scalar_nop)


text‹Rules.›

lemmas scalarI[intro] = scalar.intro

lemma scalarD[dest]:
  assumes "scalar A f"
  shows "nop A 0 f" 
  using assms unfolding scalar_def by auto

lemma scalarE[elim]:
  assumes "scalar A f"
  obtains "nop A 0 f"
  using assms by auto



subsection‹Unary operation›

locale unop = nop A ‹1ℕ› f for A f


text‹Rules.›

lemmas unopI[intro] = unop.intro

lemma unopD[dest]:
  assumes "unop A f"
  shows "nop A (1ℕ) f" 
  using assms unfolding unop_def by auto

lemma unopE[elim]:
  assumes "unop A f"
  obtains "nop A (1ℕ) f"
  using assms by blast



subsection‹Injective unary operation›

locale unop_v11 = nop_v11 A ‹1ℕ› f for A f

sublocale unop_v11 ⊆ unop A f by (intro unopI) (simp add: nop_axioms)


text‹Rules.›

lemma unop_v11I[intro]:
  assumes "nop_v11 A (1ℕ) f"
  shows "unop_v11 A f"
  using assms by (rule unop_v11.intro)

lemma unop_v11D[dest]:
  assumes "unop_v11 A f"
  shows "nop_v11 A (1ℕ) f"
  using assms by (rule unop_v11.axioms)

lemma unop_v11E[elim]:
  assumes "unop_v11 A f"
  obtains "nop_v11 A (1ℕ) f"
  using assms by blast



subsection‹Surjective unary operation›

locale unop_onto = nop_onto A ‹1ℕ› f for A f

sublocale unop_onto ⊆ unop A f by (intro unopI) (simp add: nop_axioms)


text‹Rules.›

lemma unop_ontoI[intro]:
  assumes "nop_onto A (1ℕ) f"
  shows "unop_onto A f"
  using assms by (rule unop_onto.intro)

lemma unop_ontoD[dest]:
  assumes "unop_onto A f"
  shows "nop_onto A (1ℕ) f"
  using assms by (rule unop_onto.axioms)

lemma unop_ontoE[elim]:
  assumes "unop_onto A f"
  obtains "nop_onto A (1ℕ) f"
  using assms by blast

lemma unop_ontoI'[intro]:
  assumes "unop A f" and "A ⊆∘ ℛ∘ f"
  shows "unop_onto A f"
proof-
  interpret unop A f by (rule assms(1))
  from assms(2) nop_vrange have "A = ℛ∘ f" by simp
  with assms(1) show "unop_onto A f" by auto
qed



subsection‹Bijective unary operation›

locale unop_bij = nop_bij A ‹1ℕ› f for A f

sublocale unop_bij ⊆ unop_v11 A f  
  by (intro unop_v11I) (simp add: nop_v11_axioms)

sublocale unop_bij ⊆ unop_onto A f  
  by (intro unop_ontoI) (simp add: nop_onto_axioms)


text‹Rules.›

lemma unop_bijI[intro]:
  assumes "nop_bij A (1ℕ) f"
  shows "unop_bij A f"
  using assms by (rule unop_bij.intro)

lemma unop_bijD[dest]:
  assumes "unop_bij A f"
  shows "nop_bij A (1ℕ) f"
  using assms by (rule unop_bij.axioms)

lemma unop_bijE[elim]:
  assumes "unop_bij A f"
  obtains "nop_bij A (1ℕ) f"
  using assms by blast

lemma unop_bijI'[intro]:
  assumes "unop_v11 A f" and "A ⊆∘ ℛ∘ f"
  shows "unop_bij A f"
proof-
  interpret unop_v11 A f by (rule assms(1))
  from assms(2) nop_vrange have "A = ℛ∘ f" by simp
  with assms(1) show "unop_bij A f" by auto
qed



subsection‹Partial binary operation›

locale pbinop = pnop A ‹2ℕ› f for A f

sublocale pbinop ⊆ dom: fbrelation ‹𝒟∘ f› 
proof
  from pnop_vdomain show "fpairs (𝒟∘ f) = 𝒟∘ f"
    by (intro vsubset_antisym vsubsetI) auto
qed


text‹Rules.›

lemmas pbinopI[intro] = pbinop.intro

lemma pbinopD[dest]:
  assumes "pbinop A f"
  shows "pnop A (2ℕ) f"
  using assms unfolding pbinop_def by auto

lemma pbinopE[elim]:
  assumes "pbinop A f"
  obtains "pnop A (2ℕ) f"
  using assms by auto


text‹Elementary properties.›

lemma (in pbinop) fbinop_vcard: 
  assumes "x ∈∘ 𝒟∘ f" 
  shows "vcard x = 2ℕ"
proof-
  from assms dom.fbrelation_axioms obtain a b where x_def: "x = [a, b]∘" by blast
  show ?thesis by (auto simp: x_def nat_omega_simps)
qed




subsection‹Total binary operation›

locale binop = nop A ‹2ℕ› f for A f

sublocale binop ⊆ pbinop by unfold_locales


text‹Rules.›

lemmas binopI[intro] = binop.intro

lemma binopD[dest]:
  assumes "binop A f"
  shows "nop A (2ℕ) f"
  using assms unfolding binop_def by auto

lemma binopE[elim]:
  assumes "binop A f"
  obtains "nop A (2ℕ) f"
  using assms by auto


text‹Elementary properties.›

lemma (in binop) binop_app_in_vrange[intro]:
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "f⦇a, b⦈∙ ∈∘ ℛ∘ f"
proof-
  from assms have "[a, b]∘ ∈∘ A ^× 2ℕ" by (auto simp: nat_omega_simps)
  then show ?thesis by (simp add: nop_vdomain vsv_vimageI2)
qed



subsection‹Injective binary operation›

locale binop_v11 = nop_v11 A ‹2ℕ› f for A f

sublocale binop_v11 ⊆ binop A f by (intro binopI) (simp add: nop_axioms)


text‹Rules.›

lemma binop_v11I[intro]:
  assumes "nop_v11 A (2ℕ) f"
  shows "binop_v11 A f"
  using assms by (rule binop_v11.intro)

lemma binop_v11D[dest]:
  assumes "binop_v11 A f"
  shows "nop_v11 A (2ℕ) f"
  using assms by (rule binop_v11.axioms)

lemma binop_v11E[elim]:
  assumes "binop_v11 A f"
  obtains "nop_v11 A (2ℕ) f"
  using assms by blast



subsection‹Surjective binary operation›

locale binop_onto = nop_onto A ‹2ℕ› f for A f

sublocale binop_onto ⊆ binop A f by (intro binopI) (simp add: nop_axioms)


text‹Rules.›

lemma binop_ontoI[intro]:
  assumes "nop_onto A (2ℕ) f"
  shows "binop_onto A f"
  using assms by (rule binop_onto.intro)

lemma binop_ontoD[dest]:
  assumes "binop_onto A f"
  shows "nop_onto A (2ℕ) f"
  using assms by (rule binop_onto.axioms)

lemma binop_ontoE[elim]:
  assumes "binop_onto A f"
  obtains "nop_onto A (2ℕ) f"
  using assms by blast

lemma binop_ontoI'[intro]:
  assumes "binop A f" and "A ⊆∘ ℛ∘ f"
  shows "binop_onto A f"
proof-
  interpret binop A f by (rule assms(1))
  from assms(2) nop_vrange have "A = ℛ∘ f" by simp
  with assms(1) show "binop_onto A f" by auto
qed



subsection‹Bijective binary operation›

locale binop_bij = nop_bij A ‹2ℕ› f for A f

sublocale binop_bij ⊆ binop_v11 A f 
  by (intro binop_v11I) (simp add: nop_v11_axioms)

sublocale binop_bij ⊆ binop_onto A f 
  by (intro binop_ontoI) (simp add: nop_onto_axioms)


text‹Rules.›

lemma binop_bijI[intro]:
  assumes "nop_bij A (2ℕ) f"
  shows "binop_bij A f"
  using assms by (rule binop_bij.intro)

lemma binop_bijD[dest]:
  assumes "binop_bij A f"
  shows "nop_bij A (2ℕ) f"
  using assms by (rule binop_bij.axioms)

lemma binop_bijE[elim]:
  assumes "binop_bij A f"
  obtains "nop_bij A (2ℕ) f"
  using assms by blast

lemma binop_bijI'[intro]:
  assumes "binop_v11 A f" and "A ⊆∘ ℛ∘ f"
  shows "binop_bij A f"
proof-
  interpret binop_v11 A f by (rule assms(1))
  from assms(2) nop_vrange have "A = ℛ∘ f" by simp
  with assms(1) show "binop_bij A f" by auto
qed



subsection‹Flip›

definition fflip :: "V ⇒ V"
  where "fflip f = (λab∈∘(𝒟∘ f)¯∙. f⦇ab⦇1ℕ⦈, ab⦇0⦈⦈∙)"


text‹Elementary properties.›

lemma fflip_vsv: "vsv (fflip f)"
  by (intro vsvI) (auto simp: fflip_def)

lemma vdomain_fflip[simp]: "𝒟∘ (fflip f) = (𝒟∘ f)¯∙" 
  unfolding fflip_def by simp

lemma (in pbinop) vrange_fflip: "ℛ∘ (fflip f) = ℛ∘ f"
  unfolding fflip_def
proof(intro vsubset_antisym vsubsetI)
  fix y assume "y ∈∘ ℛ∘ ((λx∈∘(𝒟∘ f)¯∙. f⦇x⦇1ℕ⦈, x⦇0⦈⦈∙))" 
  then obtain x where "x ∈∘ (𝒟∘ f)¯∙" and y_def: "y = f⦇x⦇1ℕ⦈, x⦇0⦈⦈∙" by fast
  then obtain a b where x_def: "x = [b, a]∘" by clarsimp
  have y_def': "y = f⦇a, b⦈∙" 
    unfolding y_def x_def by (simp add: nat_omega_simps)
  from x_def ‹x ∈∘ (𝒟∘ f)¯∙› have "[a, b]∘ ∈∘ 𝒟∘ f" by clarsimp
  then show "y ∈∘ ℛ∘ f" unfolding y_def' by (simp add: vsv_vimageI2)
next
  fix y assume "y ∈∘ ℛ∘ f"
  with vrange_atD obtain x where x: "x ∈∘ 𝒟∘ f" and y_def: "y = f⦇x⦈" by blast
  with dom.fbrelation obtain a b where x_def: "x = [a, b]∘" by blast
  from x have ba: "[b, a]∘ ∈∘ (𝒟∘ f)¯∙" unfolding x_def by clarsimp
  then have y_def': "y = f⦇[b, a]∘⦇1ℕ⦈, [b, a]∘⦇0⦈⦈∙"
    unfolding y_def x_def by (auto simp: nat_omega_simps)
  then show "y ∈∘ ℛ∘ ((λab∈∘(𝒟∘ f)¯∙. f⦇ab⦇1ℕ⦈, ab⦇0⦈⦈∙))"
    unfolding y_def'
    by (metis (lifting) ba beta rel_VLambda.vsv_vimageI2 vdomain_VLambda)
qed

lemma fflip_app[simp]: 
  assumes "[a, b]∘ ∈∘ 𝒟∘ f"
  shows "fflip f⦇b, a⦈∙ = f⦇a, b⦈∙"
proof-
  from assms have "[b, a]∘ ∈∘ 𝒟∘ (fflip f)" by clarsimp
  then show "fflip f⦇b, a⦈∙ = f⦇a, b⦈∙" 
    by (simp add: fflip_def ord_of_nat_succ_vempty)
qed

lemma (in pbinop) pbinop_fflip_fflip: "fflip (fflip f) = f"
proof(rule vsv_eqI)
  show "vsv (fflip (fflip f))" by (simp add: fflip_vsv)
  show "vsv f" by (rule vsv_axioms)
  show dom: "𝒟∘ (fflip (fflip f)) = 𝒟∘ f" by simp
  fix x assume prems: "x ∈∘ 𝒟∘ (fflip (fflip f))"
  with dom dom.fbrelation_axioms obtain a b where x_def: "x = [a, b]∘" by auto
  from prems show "fflip (fflip f)⦇x⦈ = f⦇x⦈" 
    unfolding x_def by (auto simp: fconverseI)
qed

lemma (in binop) pbinop_fflip_app[simp]: 
  assumes "a ∈∘ A" and "b ∈∘ A"
  shows "fflip f⦇b, a⦈∙ = f⦇a, b⦈∙"
proof-
  from assms have "[a, b]∘ ∈∘ 𝒟∘ f" 
    unfolding nop_vdomain by (auto simp: nat_omega_simps)
  then show ?thesis by auto
qed

lemma fflip_vsingleton: "fflip (set {⟨[a, b]∘, c⟩}) = set {⟨[b, a]∘, c⟩}"
proof-
  have dom_lhs: "𝒟∘ (fflip (set {⟨[a, b]∘, c⟩})) = set {[b, a]∘}"
    unfolding fflip_def by auto
  have dom_rhs: "𝒟∘ (set {⟨[b, a]∘, c⟩}) = set {[b, a]∘}" by simp
  show ?thesis
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix q assume "q ∈∘ set {[b, a]∘}"
    then have q_def: "q = [b, a]∘" by simp
    show "fflip (set {⟨[a, b]∘, c⟩})⦇q⦈ = set {⟨[b, a]∘, c⟩}⦇q⦈"
      unfolding q_def by auto
  qed (auto simp: fflip_def)
qed

text‹\newpage›

end

Theory HOL_CContinuum

(* Copyright 2021 (C) Mihails Milehins *)

section‹Intermission: upper bound on the cardinality of the continuum (HOL)›
theory HOL_CContinuum
  imports CZH_Sets_Introduction 
begin


text‹
The section presents a proof of ‹|ℝ|≤|𝒫(ℕ)|› in Isabelle/HOL. The proof is 
based on an outline at the beginning of Chapter 4 in the textbook 
‹Set Theory› by Thomas Jech \cite{jech_set_2006}.
›

lemma Pow_lepoll_mono: 
  assumes "A ≲ B"
  shows "Pow A ≲ Pow B"
  using assms by (metis Pow_mono image_Pow_surj lepoll_iff)
  
lemma rat_lepoll_nat: "(UNIV::rat set) ≲ (UNIV::nat set)" 
  unfolding lepoll_def by auto

definition rcut :: "real ⇒ real set" where "rcut r = {x∈ℚ. x < r}"

lemma inj_rcut: "inj rcut"
  unfolding rcut_def
proof(intro inj_onI)
  have xy: "x < y ⟹ {r∈ℚ. r < x} = {r∈ℚ. r < y} ⟹ x = y" for x y :: real
  proof(rule ccontr)
    assume prems: "x < y" "{r∈ℚ. r < x} = {r∈ℚ. r < y}"
    then have "{r∈ℚ. r < y} - {r∈ℚ. r < x} = {}" by simp
    with prems(1) Rats_dense_in_real show False by force
  qed
  then have yx: "y < x ⟹ {r∈ℚ. r < x} = {r∈ℚ. r < y} ⟹ x = y" 
    for x y :: real
    by auto
  show "{z ∈ ℚ. z < x} = {z ∈ ℚ. z < y} ⟹ x = y" for x y :: real 
  proof(rule ccontr)
    fix x y :: real assume prems: "{xa ∈ ℚ. xa < x} = {x ∈ ℚ. x < y}" "x ≠ y"
    from this(2) consider "x < y" | "y < x" by force
    with xy[OF _ prems(1)] yx[OF _ prems(1)] show False by cases auto
  qed
qed

lemma range_rcut_subset_Pow_rat: "range rcut ⊆ Pow ℚ"
proof(intro subsetI)
  fix x assume "x ∈ range rcut" 
  then obtain r where "x = {x∈ℚ. x < r}" unfolding rcut_def by clarsimp
  then show "x ∈ Pow ℚ" by simp
qed

lemma inj_on_inv_of_rat_rat: "inj_on (inv of_rat) ℚ"
  using inv_into_injective by (intro inj_onI) (fastforce simp: Rats_def)

lemma inj_on_inv_image_inv_of_rat_Pow_rat: "inj_on (image (inv of_rat)) (Pow ℚ)"
  by (simp add: inj_on_inv_of_rat_rat inj_on_image_Pow)

lemma inj_on_image_inv_of_rat_range_rcut: 
  "inj_on (image (inv of_rat)) (range rcut)"
  using range_rcut_subset_Pow_rat inj_on_inv_image_inv_of_rat_Pow_rat
  by (auto intro: inj_on_subset)

lemma real_lepoll_ratrat: "(UNIV::real set) ≲ (UNIV::rat set set)" 
  unfolding lepoll_def
proof(intro exI conjI)
  from inj_rcut inj_on_image_inv_of_rat_range_rcut show 
    "inj (image (inv of_rat) ∘ rcut)"
    by (rule comp_inj_on)
qed auto

lemma nat_lepoll_real: "(UNIV::nat set) ≲ (UNIV::real set)"
  using infinite_UNIV_char_0 infinite_countable_subset 
  unfolding lepoll_def 
  by blast

lemma real_lepoll_natnat: "(UNIV::real set) ≲ Pow (UNIV::nat set)"
proof-
  have "(UNIV::rat set set) ≲ (UNIV::nat set set)" 
    unfolding Pow_UNIV[symmetric] by (intro Pow_lepoll_mono rat_lepoll_nat)
  from lepoll_trans[OF real_lepoll_ratrat this] show ?thesis by simp
qed

text‹\newpage›

end

Theory CZH_Sets_ZQR

(* Copyright 2021 (C) Mihails Milehins *)

section‹
Construction of integer numbers, rational numbers and real numbers
›
theory CZH_Sets_ZQR
  imports
    "HOL-Library.Rewrite"
    CZH_Sets_NOP
    CZH_Sets_VNHS
    HOL_CContinuum
begin



subsection‹Background›


text‹

The set of real numbers ‹ℝ∘› is defined in a way such that it agrees 
with the set of natural numbers const‹ω›. However, otherwise, 
real numbers are allowed to be arbitrary sets 
in term‹Vset (ω + ω)›.\footnote{
The idea itself is not new, e.g., see \cite{chen_hotg_2021}.
}
Integer and rational numbers are exposed via canonical injections into
the set of real numbers from the types typ‹int› and typ‹rat›, respectively.
Lastly, common operations on the real, integer and rational numbers
are defined and some of their main properties are exposed. 

The primary reference for this section is the textbook
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}. Nonetheless, it is not claimed that the exposition of 
the subject presented in this section is entirely congruent with the exposition
in the aforementioned reference.

›

declare One_nat_def[simp del]

named_theorems vnumber_simps

lemmas [vnumber_simps] =  
  Collect_mem_eq Ball_def[symmetric] Bex_def[symmetric] vsubset_eq[symmetric]


text‹
Supplementary material for the evaluation of the upper bound of the
cardinality of the continuum.
›

lemma inj_image_ord_of_nat: "inj (image ord_of_nat)"
  by (intro injI) (simp add: inj_image_eq_iff inj_ord_of_nat)

lemma vlepoll_VPow_omega_if_vreal_lepoll_real:
  assumes "x ≲ (UNIV::real set)" 
  shows "set x ≲∘ VPow ω"
proof-
  note x = assms
  also from real_lepoll_natnat have "… ≲ (UNIV::nat set set)"
    unfolding Pow_UNIV by simp
  also from inj_image_ord_of_nat have "… ≲ Pow (elts ω)"
    unfolding lepoll_def by auto
  also from down have "… ≲ elts (VPow ω)"
    unfolding lepoll_def
    by (intro exI[of _ set] conjI inj_onI) (auto simp: elts_VPow)
  finally show "set x ≲∘ VPow ω" by simp
qed



subsection‹Real numbers›


subsubsection‹Definition›

abbreviation real :: "nat ⇒ real"
  where "real ≡ of_nat"

definition nat_of_real :: "real ⇒ nat"
  where "nat_of_real = inv_into UNIV real"

definition vreal_of_real_impl :: "real ⇒ V"
  where "vreal_of_real_impl = (SOME V_of::real⇒V. inj V_of)"

lemma inj_vreal_of_real_impl: "inj vreal_of_real_impl" 
  unfolding vreal_of_real_impl_def 
  by (metis embeddable_class.ex_inj verit_sko_ex')

lemma inj_on_inv_vreal_of_real_impl: 
  "inj_on (inv vreal_of_real_impl) (range vreal_of_real_impl)"
  by (intro inj_onI) (fastforce intro: inv_into_injective)

lemma range_vreal_of_real_impl_vlepoll_VPow_omega: 
  "set (range vreal_of_real_impl) ≲∘ VPow ω"
proof-
  have "range vreal_of_real_impl ≲ (UNIV::real set)"
    unfolding lepoll_def by (auto intro: inj_on_inv_vreal_of_real_impl)
  from vlepoll_VPow_omega_if_vreal_lepoll_real[OF this] show ?thesis .
qed

definition vreal_impl :: V
  where "vreal_impl =
    (
      SOME y. 
        range vreal_of_real_impl ≈ elts y ∧
        vdisjnt y ω ∧
        y ∈∘ Vset (ω + ω)
    )"

lemma vreal_impl_eqpoll: "range vreal_of_real_impl ≈ elts vreal_impl" 
  and vreal_impl_vdisjnt: "vdisjnt vreal_impl ω"
  and vreal_impl_in_Vset_ss_omega: "vreal_impl ∈∘ Vset (ω + ω)"
proof-
  from Ord_ω have VPow_in_Vset: "VPow ω ∈∘ Vset (succ (succ ω))"
    by (intro Ord_VPow_in_Vset_succI) 
      (auto simp: less_TC_succ Ord_iff_rank VsetI)
  have [simp]: "small (range vreal_of_real_impl)" by simp
  then obtain x where x: "range vreal_of_real_impl = elts x"
    unfolding small_iff by clarsimp
  from range_vreal_of_real_impl_vlepoll_VPow_omega[unfolded x] have 
    "x ≲∘ VPow ω" 
    by simp
  then obtain f where "v11 f" and "𝒟∘ f = x" and "ℛ∘ f ⊆∘ VPow ω" by auto
  moreover have Oω2: "Ord (succ (succ ω))" by auto
  ultimately have x_Rf: "x ≈∘ ℛ∘ f" and "ℛ∘ f ∈∘ Vset (succ (succ ω))"
    by (auto intro: VPow_in_Vset)
  then have "ω ∪∘ ℛ∘ f ∈∘ Vset (succ (succ ω))" and "ℛ∘ f ⊆∘ ω ∪∘ ℛ∘ f"
    by (auto simp: VPow_in_Vset VPow_in_Vset_revD vunion_in_VsetI)
  from Ord_ex_eqpoll_vdisjnt[OF Oω2 this(2,1)] obtain z
    where Rf_z: "ℛ∘ f ≈∘ z" 
      and "vdisjnt z (ω ∪∘ ℛ∘ f)"
      and z: "z ⊆∘ Vset (succ (succ (succ ω)))"
    by auto
  then have vdisjnt_zω: "vdisjnt z ω" 
    and z_ssssω: "z ∈∘ Vset (succ (succ (succ (succ ω))))"    
    by 
      (
        auto simp: 
          vdisjnt_vunion_right vsubset_in_VsetI Ord_succ Ord_Vset_in_Vset_succI
      )
  have "Limit (ω + ω)" by simp
  then have "succ (succ (succ (succ ω))) ∈∘ ω + ω"
    by (metis Limit_def add.right_neutral add_mem_right_cancel Limit_omega)
  then have "Vset (succ (succ (succ (succ ω)))) ∈∘ Vset (ω + ω)"
    by (simp add: Vset_in_mono)
  with z z_ssssω have "z ∈∘ Vset (ω + ω)" by auto
  moreover from x_Rf Rf_z have "range vreal_of_real_impl ≈ elts z"
    unfolding x by (auto intro: eqpoll_trans)
  ultimately show "range vreal_of_real_impl ≈ elts vreal_impl" 
    and "vdisjnt vreal_impl ω"
    and "vreal_impl ∈∘ Vset (ω + ω)"
    using vdisjnt_zω 
    unfolding vreal_impl_def
    by (metis (mono_tags, lifting) verit_sko_ex')+
qed

definition vreal_of_real_impl' :: "V ⇒ V"
  where "vreal_of_real_impl' = 
    (SOME f. bij_betw f (range vreal_of_real_impl) (elts vreal_impl))"

lemma vreal_of_real_impl'_bij_betw: 
  "bij_betw vreal_of_real_impl' (range vreal_of_real_impl) (elts vreal_impl)"
proof-
  from eqpoll_def obtain f where f: 
    "bij_betw f (range vreal_of_real_impl) (elts vreal_impl)"
    by (auto intro: vreal_impl_eqpoll)
  then show ?thesis unfolding vreal_of_real_impl'_def by (metis verit_sko_ex')
qed

definition vreal_of_real_impl'' :: "real ⇒ V"
  where "vreal_of_real_impl'' = vreal_of_real_impl' ∘ vreal_of_real_impl"

lemma vreal_of_real_impl'': "disjnt (range vreal_of_real_impl'') (elts ω)"
proof-
  from comp_apply vreal_impl_vdisjnt vreal_of_real_impl'_bij_betw have 
    "vreal_of_real_impl'' y ∉∘ ω" for y
    unfolding vreal_of_real_impl''_def by fastforce
  then show ?thesis unfolding disjnt_iff by clarsimp
qed

lemma inj_vreal_of_real_impl'': "inj vreal_of_real_impl''"
  unfolding vreal_of_real_impl''_def 
  by 
    (
      meson 
        bij_betwE 
        comp_inj_on 
        inj_vreal_of_real_impl 
        vreal_of_real_impl'_bij_betw
    )


text‹Main definitions.›

definition vreal_of_real :: "real ⇒ V"
  where "vreal_of_real x = 
    (if x ∈ ℕ then (nat_of_real x)ℕ else vreal_of_real_impl'' x)"

notation vreal_of_real (‹_ℝ› [1000] 999)

declare [[coercion "vreal_of_real :: real ⇒ V"]]

definition vreal :: V (‹ℝ∘›)
  where "vreal = set (range vreal_of_real)"

definition real_of_vreal :: "V ⇒ real"
  where "real_of_vreal = inv_into UNIV vreal_of_real"


text‹Rules.›

lemma vreal_of_real_in_vrealI[intro, simp]: "aℝ ∈∘ ℝ∘" 
  by (simp add: vreal_def)

lemma vreal_of_real_in_vrealE[elim]:
  assumes "a ∈∘ ℝ∘"
  obtains b where "bℝ = a"
  using assms unfolding vreal_def by auto


text‹Elementary properties.›

lemma vnat_eq_vreal: "xℕ = xℝ" by (simp add: nat_of_real_def vreal_of_real_def)

lemma omega_vsubset_vreal: "ω ⊆∘ ℝ∘"
proof
  fix x assume "x ∈∘ ω"
  with nat_of_omega obtain y where x_def: "x = yℕ" by auto
  then have "vreal_of_real (real y) = (nat_of_real (real y))ℕ" 
    unfolding vreal_of_real_def by simp
  moreover have "(nat_of_real (real y))ℕ = x"
    by (simp add: nat_of_real_def x_def)
  ultimately show "x ∈∘ ℝ∘" unfolding vreal_def by clarsimp
qed

lemma inj_vreal_of_real: "inj vreal_of_real"
proof
  fix x y assume prems: "vreal_of_real x = vreal_of_real y"
  consider 
    (xy) ‹x ∈ ℕ ∧ y ∈ ℕ› | 
    (x_ny) ‹x ∈ ℕ ∧ y ∉ ℕ› | 
    (nx_y) ‹x ∉ ℕ ∧ y ∈ ℕ› | 
    (nxy) ‹x ∉ ℕ ∧ y ∉ ℕ›  
    by auto 
  then show "x = y"
  proof cases
    case xy
    then have "(nat_of_real x)ℕ = (nat_of_real y)ℕ"
      using vreal_of_real_def prems by simp
    then show ?thesis
      by (metis Nats_def f_inv_into_f nat_of_real_def ord_of_nat_inject xy)
  next
    case x_ny
    with prems have eq: "(nat_of_real x)ℕ = vreal_of_real_impl'' y"
      unfolding vreal_of_real_def by simp
    have "vreal_of_real_impl'' y ∉∘ ω"
      by (meson disjnt_iff rangeI vreal_of_real_impl'')
    then show ?thesis unfolding eq[symmetric] by auto
  next
    case nx_y
    with prems have eq: "(nat_of_real y)ℕ = vreal_of_real_impl'' x"
      unfolding vreal_of_real_def by simp
    have "vreal_of_real_impl'' x ∉∘ ω"
      by (meson disjnt_iff rangeI vreal_of_real_impl'')
    then show ?thesis unfolding eq[symmetric] by auto
  next
    case nxy
    then have "x ∉ ℕ" and "y ∉ ℕ" by auto
    with prems 
    have "vreal_of_real_impl'' x = vreal_of_real_impl'' y"
      unfolding vreal_of_real_def by simp
    then show ?thesis by (meson inj_def inj_vreal_of_real_impl'')
  qed
qed

lemma vreal_in_Vset_ω2: "ℝ∘ ∈∘ Vset (ω + ω)"
  unfolding vreal_def
proof-
  have "set (range vreal_of_real) ⊆∘ set (range vreal_of_real_impl'') ∪∘ ω"
    unfolding vreal_of_real_def by auto
  moreover from vreal_of_real_impl'_bij_betw have 
    "set (range vreal_of_real_impl'') ⊆∘ vreal_impl"
    unfolding vreal_of_real_impl''_def by fastforce
  ultimately show "set (range vreal_of_real) ∈∘ Vset (ω + ω)"
    using Ord_ω Ord_add 
    by 
      ( 
        auto simp: 
          Ord_iff_rank 
          Ord_VsetI
          vreal_impl_in_Vset_ss_omega 
          vsubset_in_VsetI 
          vunion_in_VsetI
      )
qed

lemma real_of_vreal_vreal_of_real[simp]: "real_of_vreal (aℝ) = a"
  by (simp add: inj_vreal_of_real real_of_vreal_def)


subsubsection‹Transfer rules›

definition cr_vreal :: "V ⇒ real ⇒ bool"
  where "cr_vreal a b ⟷ (a = vreal_of_real b)"

lemma cr_vreal_right_total[transfer_rule]: "right_total cr_vreal"
  unfolding cr_vreal_def right_total_def by simp

lemma cr_vreal_bi_uniqie[transfer_rule]: "bi_unique cr_vreal"
  unfolding cr_vreal_def bi_unique_def
  by (simp add: inj_eq inj_vreal_of_real)

lemma cr_vreal_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_vreal = (λx. x ∈∘ ℝ∘)"
  unfolding cr_vreal_def by force

lemma vreal_transfer[transfer_rule]: 
  "(rel_set cr_vreal) (elts ℝ∘) (UNIV::real set)"
  unfolding cr_vreal_def rel_set_def by auto

lemma vreal_of_real_transfer[transfer_rule]: "cr_vreal (vreal_of_real a) a"
  unfolding cr_vreal_def by auto


subsubsection‹Constants and operations›


text‹Auxiliary.›

lemma vreal_fsingleton_in_fproduct_vreal: "[aℝ]∘ ∈∘ ℝ∘ ^× 1ℕ" by auto

lemma vreal_fpair_in_fproduct_vreal: "[aℝ, bℝ]∘ ∈∘ ℝ∘ ^× 2ℕ" by force


text‹Zero.›

lemma vreal_zero: "0ℝ = (0::V)" 
  by (simp add: ord_of_nat_vempty vnat_eq_vreal)


text‹One.›

lemma vreal_one: "1ℝ = (1::V)" 
  by (simp add: ord_of_nat_vone vnat_eq_vreal)


text‹Addition.›

definition vreal_plus :: V 
  where "vreal_plus = 
    (λx∈∘ℝ∘ ^× 2ℕ. (real_of_vreal (x⦇0ℕ⦈) + real_of_vreal (x⦇1ℕ⦈))ℝ)"

abbreviation vreal_plus_app :: "V ⇒ V ⇒ V" (infixl "+ℝ" 65)
  where "vreal_plus_app a b ≡ vreal_plus⦇a, b⦈∙"
notation vreal_plus_app (infixl "+ℝ" 65)

lemma vreal_plus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal ===> cr_vreal) 
    (+ℝ) (+)"
  using vreal_fpair_in_fproduct_vreal 
  by (intro rel_funI, unfold vreal_plus_def cr_vreal_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Multiplication.›

definition vreal_mult :: V 
  where "vreal_mult = 
    (λx∈∘ℝ∘ ^× 2ℕ. (real_of_vreal (x⦇0ℕ⦈) * real_of_vreal (x⦇1ℕ⦈))ℝ)"

abbreviation vreal_mult_app (infixl "*ℝ" 70) 
  where "vreal_mult_app a b ≡ vreal_mult⦇a, b⦈∙"
notation vreal_mult_app (infixl "*ℝ" 70)

lemma vreal_mult_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal ===> cr_vreal) (*ℝ) (*)"
  using vreal_fpair_in_fproduct_vreal 
  by (intro rel_funI, unfold vreal_mult_def cr_vreal_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Unary minus.›

definition vreal_uminus :: V 
  where "vreal_uminus = (λx∈∘ℝ∘. (uminus (real_of_vreal x))ℝ)"

abbreviation vreal_uminus_app (‹-ℝ _› [81] 80) 
  where "-ℝ a ≡ vreal_uminus⦇a⦈"

lemma vreal_uminus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal) (vreal_uminus_app) (uminus)"
  using vreal_fsingleton_in_fproduct_vreal
  by (intro rel_funI, unfold vreal_uminus_def cr_vreal_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Multiplicative inverse.›

definition vreal_inverse :: V 
  where "vreal_inverse = (λx∈∘ℝ∘. (inverse (real_of_vreal x))ℝ)"

abbreviation vreal_inverse_app (‹(_¯ℝ)› [1000] 999) 
  where "a¯ℝ ≡ vreal_inverse⦇a⦈"

lemma vreal_inverse_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal) (vreal_inverse_app) (inverse)"
  using vreal_fsingleton_in_fproduct_vreal 
  by (intro rel_funI, unfold vreal_inverse_def cr_vreal_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Order.›

definition vreal_le :: V 
  where "vreal_le =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ ∧ real_of_vreal a ≤ real_of_vreal b}"

abbreviation vreal_le' (‹(_/ ≤ℝ _)›  [51, 51] 50)
  where "a ≤ℝ b ≡ [a, b]∘ ∈∘ vreal_le"

lemma small_vreal_le[simp]: 
  "small 
    {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ ∧ real_of_vreal a ≤ real_of_vreal b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vreal_le_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal ===> (=)) vreal_le' (≤)"
  using vreal_fsingleton_in_fproduct_vreal 
  by (intro rel_funI, unfold cr_scalar_def cr_vreal_def vreal_le_def)
    (auto simp: nat_omega_simps)


text‹Strict order.›

definition vreal_ls :: V 
  where "vreal_ls =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ ∧ real_of_vreal a < real_of_vreal b}"

abbreviation vreal_ls' (‹(_/ <ℝ _)› [51, 51] 50)
  where "a <ℝ b ≡ [a, b]∘ ∈∘ vreal_ls"

lemma small_vreal_ls[simp]: 
  "small 
    {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ ∧ real_of_vreal a < real_of_vreal b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℝ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vreal_ls_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal ===> (=)) vreal_ls' (<)"
  by (intro rel_funI, unfold cr_scalar_def cr_vreal_def vreal_ls_def)
    (auto simp: nat_omega_simps)
  

text‹Subtraction.›

definition vreal_minus :: V 
  where "vreal_minus =
    (λx∈∘ℝ∘ ^× 2ℕ. (real_of_vreal (x⦇0ℕ⦈) - real_of_vreal (x⦇1ℕ⦈))ℝ)"

abbreviation vreal_minus_app (infixl "-ℝ" 65) 
  where "vreal_minus_app a b ≡ vreal_minus⦇a, b⦈∙"

lemma vreal_minus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vreal ===> cr_vreal ===> cr_vreal) (-ℝ) (-)"
  using vreal_fpair_in_fproduct_vreal 
  by (intro rel_funI, unfold vreal_minus_def cr_vreal_def cr_scalar_def) 
    (simp add: nat_omega_simps)


subsubsection‹Axioms of an ordered field with the least upper bound property.›


text‹
The exposition follows the Definitions 2.2.1 and 2.2.3 from 
the textbook ‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.
›

lemma vreal_zero_closed: "0ℝ ∈∘ ℝ∘"
proof-
  have "(0::real) ∈ UNIV" by simp
  from this[untransferred] show ?thesis.
qed

lemma vreal_one_closed: "1ℝ ∈∘ ℝ∘"
proof-
  have "(1::real) ∈ UNIV" by simp
  from this[untransferred] show ?thesis.
qed

lemma vreal_plus_closed: 
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" 
  shows "x +ℝ y ∈∘ ℝ∘"
proof-
  have "x' + y' ∈ UNIV" for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vreal_uminus_closed: 
  assumes "x ∈∘ ℝ∘"
  shows "-ℝ x ∈∘ ℝ∘"
proof-
  have "-x' ∈ UNIV" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vreal_mult_closed:
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" 
  shows "x *ℝ y ∈∘ ℝ∘"
proof-
  have "x' * y' ∈ UNIV" for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vreal_inverse_closed: 
  assumes "x ∈∘ ℝ∘"
  shows "x¯ℝ ∈∘ ℝ∘"
proof-    
  have "inverse x' ∈ UNIV" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Addition: Definition 2.2.1.a.›

lemma vreal_assoc_law_addition: 
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" and "z ∈∘ ℝ∘" 
  shows "(x +ℝ y) +ℝ z = x +ℝ (y +ℝ z)"
proof-
  have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Addition: Definition 2.2.1.b.›

lemma vreal_commutative_law_addition:
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" 
  shows "x +ℝ y = y +ℝ x"
proof-
  have "(x' + y') = y' + x' " for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for Addition: Definition 2.2.1.c.›

lemma vreal_identity_law_addition:
  assumes "x ∈∘ ℝ∘"
  shows "x +ℝ 0ℝ = x"
proof-
  have "x' + 0 = x'" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Inverses Law for Addition: Definition 2.2.1.d.›

lemma vreal_inverses_law_addition:
  assumes "x ∈∘ ℝ∘"
  shows "x +ℝ (-ℝ x) = 0ℝ"
proof-
  have "x' + (-x') = 0" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Multiplication: Definition 2.2.1.e.›

lemma vreal_assoc_law_multiplication: 
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" and "z ∈∘ ℝ∘"
  shows "(x *ℝ y) *ℝ z = x *ℝ (y *ℝ z)"
proof-
  have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Multiplication: Definition 2.2.1.f.›

lemma vreal_commutative_law_multiplication:
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" 
  shows "x *ℝ y = y *ℝ x"
proof-
  have "(x' * y') = y' * x' " for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for Multiplication: Definition 2.2.1.g.›

lemma vreal_identity_law_multiplication:
  assumes "x ∈∘ ℝ∘"
  shows "x *ℝ 1ℝ = x"
proof-
  have "x' * 1 = x'" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Inverses Law for Multiplication: Definition 2.2.1.h.›

lemma vreal_inverses_law_multiplication:
  assumes "x ∈∘ ℝ∘" and "x ≠ 0ℝ" 
  shows "x *ℝ x¯ℝ = 1ℝ"
proof-
  have "x' ≠ 0 ⟹ x' * inverse x' = 1" for x' :: real by simp  
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Distributive Law: Definition 2.2.1.i.›

lemma vreal_distributive_law:
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" and "z ∈∘ ℝ∘"
  shows "x *ℝ (y +ℝ z) = x *ℝ y +ℝ x *ℝ z"
proof-
  have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: real 
    by (simp add: field_simps)
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Trichotomy Law: Definition 2.2.1.j.›

lemma vreal_trichotomy_law:
  assumes "x ∈∘ ℝ∘" "y ∈∘ ℝ∘"
  shows 
    "(x <ℝ y ∧ ~(x = y) ∧ ~(y <ℝ x)) ∨ 
    (~(x <ℝ y) ∧ x = y ∧ ~(y <ℝ x)) ∨
    (~(x <ℝ y) ∧ ~(x = y) ∧ y <ℝ x)"
proof-
  have "(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨ 
    (~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
    (~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
    for x' y' z' :: real 
    by auto
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Transitive Law: Definition 2.2.1.k.›

lemma vreal_transitive_law:
  assumes "x ∈∘ ℝ∘" 
    and "y ∈∘ ℝ∘" 
    and "z ∈∘ ℝ∘" 
    and "x <ℝ y" and "y <ℝ z"
  shows "x <ℝ z"
proof-
  have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Addition Law of Order: Definition 2.2.1.l.›

lemma vreal_addition_law_of_order:
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘" and "z ∈∘ ℝ∘" and "x <ℝ y"
  shows "x +ℝ z <ℝ y +ℝ z"
proof-
  have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Multiplication Law of Order: Definition 2.2.1.m.›

lemma vreal_multiplication_law_of_order:
  assumes "x ∈∘ ℝ∘" 
    and "y ∈∘ ℝ∘" 
    and "z ∈∘ ℝ∘" 
    and "x <ℝ y" 
    and "0ℝ <ℝ z"
  shows "x *ℝ z <ℝ y *ℝ z"
proof-
  have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Non-Triviality: Definition 2.2.1.n.›

lemma vreal_non_triviality: "0ℝ ≠ 1ℝ"
proof-
  have "0 ≠ (1::real)" by simp
  from this[untransferred] show ?thesis.
qed


text‹Least upper bound property: Definition 2.2.3.›

lemma least_upper_bound_property:
  defines "vreal_ub S M ≡ (S ⊆∘ ℝ∘ ∧ M ∈∘ ℝ∘ ∧ (∀x∈∘S. x ≤ℝ M))"
  assumes "A ⊆∘ ℝ∘" and "A ≠ 0" and "∃M. vreal_ub A M"
  obtains M where "vreal_ub A M" and "⋀T. vreal_ub A T ⟹ M ≤ℝ T"
proof-
  note complete_real = 
    complete_real[
      untransferred, of ‹elts A›, unfolded vnumber_simps, OF assms(2)
      ]
  from assms obtain x where "x ∈∘ A" by force
  moreover with assms have "x ∈∘ ℝ∘" by auto
  ultimately have 1: "∃x∈∘ℝ∘. x ∈∘ A" by auto
  from assms have 2: "∃x∈∘ℝ∘. ∀y∈∘A. y ≤ℝ x" by auto
  from complete_real[OF 1 2] 
    obtain M
      where "M ∈∘ ℝ∘" 
        and "⋀x. x ∈∘ A ⟹ x ≤ℝ M" 
        and [simp]: "⋀T. T ∈∘ ℝ∘ ⟹ (⋀x. x ∈∘ A ⟹ x ≤ℝ T) ⟹ M ≤ℝ T"
    by force
  with assms(2) have "vreal_ub A M" unfolding vreal_ub_def by simp
  moreover have "vreal_ub A T ⟹ M ≤ℝ T" for T unfolding vreal_ub_def by simp
  ultimately show ?thesis using that by auto
qed


subsubsection‹Fundamental properties of other operations›


text‹Minus.›

lemma vreal_minus_closed: 
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘"
  shows "x -ℝ y ∈∘ ℝ∘"
proof-
  have "x' - y' ∈ UNIV" for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vreal_minus_eq_plus_uminus: 
  assumes "x ∈∘ ℝ∘" and "y ∈∘ ℝ∘"
  shows "x -ℝ y = x +ℝ (-ℝ y)"
proof-
  have "x' - y' = x' + (-y')" for x' y' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Unary minus.›

lemma vreal_uminus_uminus: 
  assumes "x ∈∘ ℝ∘" 
  shows "x = -ℝ (-ℝ x)"
proof-
  have "x' = -(-x')" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Multiplicative inverse.›

lemma vreal_inverse_inverse: 
  assumes "x ∈∘ ℝ∘" 
  shows "x = (x¯ℝ)¯ℝ"
proof-
  have "x' = inverse (inverse x')" for x' :: real by simp
  from this[untransferred, OF assms] show ?thesis.
qed


subsubsection‹Further properties›


text‹Addition.›

global_interpretation vreal_plus: binop_onto ‹ℝ∘› vreal_plus
proof-
  have binop: "binop ℝ∘ vreal_plus"
  proof(intro binopI nopI)
    show vsv: "vsv vreal_plus" unfolding vreal_plus_def by auto
    interpret vsv vreal_plus by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vreal_plus = ℝ∘ ^× 2ℕ" unfolding vreal_plus_def by simp
    show "ℛ∘ vreal_plus ⊆∘ ℝ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vreal_plus"
      then obtain ab where "ab ∈∘ ℝ∘ ^× 2ℕ" and y_def: "y = vreal_plus⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℝ∘" and b: "b ∈∘ ℝ∘"
        by blast
      then show "y ∈∘ ℝ∘" by (simp add: vreal_plus_closed y_def)
    qed
  qed
  interpret binop ‹ℝ∘› vreal_plus by (rule binop)
  show "binop_onto ℝ∘ vreal_plus"
  proof(intro binop_ontoI')
    show "binop ℝ∘ vreal_plus" by (rule binop_axioms)
    show "ℝ∘ ⊆∘ ℛ∘ vreal_plus"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℝ∘"
      moreover from vreal_zero vreal_zero_closed have "0 ∈∘ ℝ∘" by auto
      ultimately have "y +ℝ 0 ∈∘ ℛ∘ vreal_plus" by auto
      moreover from prems vreal_identity_law_addition have "y = y +ℝ 0" 
        by (simp add: vreal_zero)
      ultimately show "y ∈∘ ℛ∘ vreal_plus" by simp
    qed
  qed
qed


text‹Unary minus.›

global_interpretation vreal_uminus: v11 vreal_uminus
  rewrites "𝒟∘ vreal_uminus = ℝ∘"
    and "ℛ∘ vreal_uminus = ℝ∘"
proof-
  show v11: "v11 vreal_uminus" 
  proof(intro v11I)
    show vsv: "vsv vreal_uminus" unfolding vreal_uminus_def by simp
    interpret vsv vreal_uminus by (rule vsv)
    show "vsv (vreal_uminus¯∘)"
    proof(intro vsvI)
      show "vbrelation (vreal_uminus¯∘)" by clarsimp
      fix a b c
      assume prems: "⟨a, b⟩ ∈∘ vreal_uminus¯∘" "⟨a, c⟩ ∈∘ vreal_uminus¯∘"
      then have ba: "⟨b, a⟩ ∈∘ vreal_uminus" and ca: "⟨c, a⟩ ∈∘ vreal_uminus" 
        by auto
      then have b: "b ∈∘ ℝ∘" and c: "c ∈∘ ℝ∘" 
        by (simp_all add: VLambda_iff2 vreal_uminus_def)
      from ba ca have "a = -ℝ b" "a = -ℝ c" by simp_all
      with ba ca b c show "b = c"  by (metis vreal_uminus_uminus)
    qed
  qed
  interpret v11 vreal_uminus by (rule v11)
  show dom: "𝒟∘ vreal_uminus = ℝ∘" unfolding vreal_uminus_def by simp
  have "ℛ∘ vreal_uminus ⊆∘ ℝ∘"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ vreal_uminus"
    then obtain x where "x ∈∘ ℝ∘" and y_def: "y = -ℝ x" 
      unfolding dom[symmetric] by force
    then show "y ∈∘ ℝ∘" by (simp add: vreal_uminus_closed)
  qed
  moreover have "ℝ∘ ⊆∘ ℛ∘ vreal_uminus"
    by (intro vsubsetI) 
      (metis dom vdomain_atD vreal_uminus_closed vreal_uminus_uminus)
  ultimately show "ℛ∘ vreal_uminus = ℝ∘" by simp
qed


text‹Multiplication.›

global_interpretation vreal_mult: binop_onto ‹ℝ∘› vreal_mult
proof-
  have binop: "binop ℝ∘ vreal_mult"
  proof(intro binopI nopI)
    show vsv: "vsv vreal_mult" unfolding vreal_mult_def by auto
    interpret vsv vreal_mult by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vreal_mult = ℝ∘ ^× 2ℕ" unfolding vreal_mult_def by simp
    show "ℛ∘ vreal_mult ⊆∘ ℝ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vreal_mult"
      then obtain ab where "ab ∈∘ ℝ∘ ^× 2ℕ" and y_def: "y = vreal_mult⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℝ∘" and b: "b ∈∘ ℝ∘"
        by blast
      then show "y ∈∘ ℝ∘" by (simp add: vreal_mult_closed y_def)
    qed
  qed
  interpret binop ‹ℝ∘› vreal_mult by (rule binop)
  show "binop_onto ℝ∘ vreal_mult"
  proof(intro binop_ontoI')
    show "binop ℝ∘ vreal_mult" by (rule binop_axioms)
    show "ℝ∘ ⊆∘ ℛ∘ vreal_mult"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℝ∘"
      moreover from vreal_one vreal_one_closed have "1 ∈∘ ℝ∘" by auto
      ultimately have "y *ℝ 1 ∈∘ ℛ∘ vreal_mult" by auto
      moreover from prems vreal_identity_law_multiplication have "y = y *ℝ 1" 
        by (simp add: vreal_one)
      ultimately show "y ∈∘ ℛ∘ vreal_mult" by simp
    qed
  qed
qed


text‹Multiplicative inverse.›

global_interpretation vreal_inverse: v11 vreal_inverse
  rewrites "𝒟∘ vreal_inverse = ℝ∘"
    and "ℛ∘ vreal_inverse = ℝ∘"
proof-
  show v11: "v11 vreal_inverse" 
  proof(intro v11I)
    show vsv: "vsv vreal_inverse" unfolding vreal_inverse_def by simp
    interpret vsv vreal_inverse by (rule vsv)
    show "vsv (vreal_inverse¯∘)"
    proof(intro vsvI)
      show "vbrelation (vreal_inverse¯∘)" by clarsimp
      fix a b c
      assume prems: "⟨a, b⟩ ∈∘ vreal_inverse¯∘" "⟨a, c⟩ ∈∘ vreal_inverse¯∘"
      then have ba: "⟨b, a⟩ ∈∘ vreal_inverse" and ca: "⟨c, a⟩ ∈∘ vreal_inverse" 
        by auto
      then have b: "b ∈∘ ℝ∘" and c: "c ∈∘ ℝ∘" 
        by (simp_all add: VLambda_iff2 vreal_inverse_def)
      from ba ca have "a = b¯ℝ" "a = c¯ℝ" by simp_all
      with ba ca b c show "b = c"  by (metis vreal_inverse_inverse)
    qed
  qed
  interpret v11 vreal_inverse by (rule v11)
  show dom: "𝒟∘ vreal_inverse = ℝ∘" unfolding vreal_inverse_def by simp
  have "ℛ∘ vreal_inverse ⊆∘ ℝ∘"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ vreal_inverse"
    then obtain x where "x ∈∘ ℝ∘" and y_def: "y = x¯ℝ" 
      unfolding dom[symmetric] by force
    then show "y ∈∘ ℝ∘" by (simp add: vreal_inverse_closed)
  qed
  moreover have "ℝ∘ ⊆∘ ℛ∘ vreal_inverse"
    by (intro vsubsetI) 
      (metis dom vdomain_atD vreal_inverse_closed vreal_inverse_inverse)
  ultimately show "ℛ∘ vreal_inverse = ℝ∘" by simp
qed



subsection‹Integer numbers›


subsubsection‹Definition›

definition vint_of_int :: "int ⇒ V"
  where "vint_of_int = vreal_of_real"

notation vint_of_int (‹_ℤ› [999] 999)

declare [[coercion "vint_of_int :: int ⇒ V"]]

definition vint :: V (‹ℤ∘›)
  where "vint = set (range vint_of_int)"

definition int_of_vint :: "V ⇒ int"
  where "int_of_vint = inv_into UNIV vint_of_int"


text‹Rules.›

lemma vint_of_int_in_vintI[intro, simp]: "aℤ ∈∘ ℤ∘" by (simp add: vint_def)

lemma vint_of_int_in_vintE[elim]:
  assumes "a ∈∘ ℤ∘"
  obtains b where "bℤ = a"
  using assms unfolding vint_def by auto


subsubsection‹Elementary properties›

lemma vint_vsubset_vreal: "ℤ∘ ⊆∘ ℝ∘"
  unfolding vint_def vint_of_int_def vreal_def using image_cong by auto

lemma inj_vint_of_int: "inj vint_of_int"
  using inj_vreal_of_real 
  unfolding vint_of_int_def inj_def of_int_eq_iff
  by force

lemma vint_in_Vset_ω2: "ℤ∘ ∈∘ Vset (ω + ω)"
  using vint_vsubset_vreal vreal_in_Vset_ω2 by auto

lemma int_of_vint_vint_of_int[simp]: "int_of_vint (aℤ) = a"
  by (simp add: inj_vint_of_int int_of_vint_def)


text‹Transfer rules.›

definition cr_vint :: "V ⇒ int ⇒ bool"
  where "cr_vint a b ⟷ (a = vint_of_int b)"

lemma cr_vint_right_total[transfer_rule]: "right_total cr_vint"
  unfolding cr_vint_def right_total_def by simp

lemma cr_vint_bi_unqie[transfer_rule]: "bi_unique cr_vint"
  unfolding cr_vint_def bi_unique_def
  by (simp add: inj_eq inj_vint_of_int)

lemma cr_vint_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_vint = (λx. x ∈∘ ℤ∘)"
  unfolding cr_vint_def by force

lemma vint_transfer[transfer_rule]: 
  "(rel_set cr_vint) (elts ℤ∘) (UNIV::int set)"
  unfolding cr_vint_def rel_set_def by auto

lemma vint_of_int_transfer[transfer_rule]: "cr_vint (vint_of_int a) a"
  unfolding cr_vint_def by auto


subsubsection‹Constants and operations›


text‹Auxiliary.›

lemma vint_fsingleton_in_fproduct_vint: "[aℤ]∘ ∈∘ ℤ∘ ^× 1ℕ" by auto

lemma vint_fpair_in_fproduct_vint: "[aℤ, bℤ]∘ ∈∘ ℤ∘ ^× 2ℕ" by force


text‹Zero.›

lemma vint_zero: "0ℤ = (0::V)" by (simp add: vint_of_int_def vreal_zero)


text‹One.›

lemma vint_one: "1ℤ = (1::V)" by (simp add: vreal_one vint_of_int_def)
  

text‹Addition.›

definition vint_plus :: V 
  where "vint_plus = 
    (λx∈∘ℤ∘ ^× 2ℕ. (int_of_vint (x⦇0ℕ⦈) + int_of_vint (x⦇1ℕ⦈))ℤ)"

abbreviation vint_plus_app (infixl "+ℤ" 65) 
  where "vint_plus_app a b ≡ vint_plus⦇a, b⦈∙"

lemma vint_plus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint ===> cr_vint) (+ℤ) (+)"
  using vint_fpair_in_fproduct_vint
  by (intro rel_funI, unfold vint_plus_def cr_vint_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Multiplication.›

definition vint_mult :: V 
  where "vint_mult = 
    (λx∈∘ℤ∘ ^× 2ℕ. (int_of_vint (x⦇0ℕ⦈) * int_of_vint (x⦇1ℕ⦈))ℤ)"

abbreviation vint_mult_app (infixl "*ℤ" 65) 
  where "vint_mult_app a b ≡ vint_mult⦇a, b⦈∙"

lemma vint_mult_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint ===> cr_vint) (*ℤ) (*)"
  using vint_fpair_in_fproduct_vint
  by (intro rel_funI, unfold vint_mult_def cr_vint_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Unary minus.›

definition vint_uminus :: V 
  where "vint_uminus = (λx∈∘ℤ∘. (uminus (int_of_vint x))ℤ)"

abbreviation vint_uminus_app ("-ℤ _" [81] 80) 
  where "-ℤ a ≡ vint_uminus⦇a⦈"

lemma vint_uminus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint) (vint_uminus_app) (uminus)"
  using vint_fsingleton_in_fproduct_vint 
  by (intro rel_funI, unfold vint_uminus_def cr_vint_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Order.›

definition vint_le :: V 
  where "vint_le =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ ∧ int_of_vint a ≤ int_of_vint b}"

abbreviation vint_le' ("(_/ ≤ℤ _)"  [51, 51] 50)
  where "a ≤ℤ b ≡ [a, b]∘ ∈∘ vint_le"

lemma small_vint_le[simp]: 
  "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ ∧ int_of_vint a ≤ int_of_vint b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vint_le_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint ===> (=)) vint_le' (≤)"
  using vint_fsingleton_in_fproduct_vint 
  by (intro rel_funI, unfold cr_scalar_def cr_vint_def vint_le_def)
    (auto simp: nat_omega_simps)


text‹Strict order.›

definition vint_ls :: V 
  where "vint_ls =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ ∧ int_of_vint a < int_of_vint b}"

abbreviation vint_ls' ("(_/ <ℤ _)"  [51, 51] 50)
  where "a <ℤ b ≡ [a, b]∘ ∈∘ vint_ls"

lemma small_vint_ls[simp]: 
  "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ ∧ int_of_vint a < int_of_vint b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℤ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vint_ls_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint ===> (=)) vint_ls' (<)"
  using vint_fsingleton_in_fproduct_vint 
  by (intro rel_funI, unfold cr_scalar_def cr_vint_def vint_ls_def)
    (auto simp: nat_omega_simps)


text‹Subtraction.›

definition vint_minus :: V 
  where "vint_minus = 
    (λx∈∘ℤ∘ ^× 2ℕ. (int_of_vint (x⦇0ℕ⦈) - int_of_vint (x⦇1ℕ⦈))ℤ)"

abbreviation vint_minus_app (infixl "-ℤ" 65) 
  where "vint_minus_app a b ≡ vint_minus⦇a, b⦈∙"

lemma vint_minus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vint ===> cr_vint ===> cr_vint) 
    (-ℤ) (-)"
  using vint_fpair_in_fproduct_vint
  by (intro rel_funI, unfold vint_minus_def cr_vint_def cr_scalar_def) 
    (simp add: nat_omega_simps)


subsubsection‹Axioms of a well ordered integral domain›


text‹The exposition follows Definition 1.4.1 from the textbook 
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.›

lemma vint_zero_closed: "0ℤ ∈∘ ℤ∘" by auto

lemma vint_one_closed: "1ℤ ∈∘ ℤ∘" by auto

lemma vint_plus_closed: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘"
  shows "x +ℤ y ∈∘ ℤ∘"
proof-
  have "x' + y' ∈ UNIV" for x' y' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vint_mult_closed:
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" 
  shows "x *ℤ y ∈∘ ℤ∘"
proof-
  have "(x'::int) * y' ∈ UNIV" for x' y' by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vint_uminus_closed: 
  assumes "x ∈∘ ℤ∘"
  shows "-ℤ x ∈∘ ℤ∘"
proof-
  have "(-x'::int) ∈ UNIV" for x' by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Addition: Definition 1.4.1.a.›

lemma vint_assoc_law_addition: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" and "z ∈∘ ℤ∘"  
  shows "(x +ℤ y) +ℤ z = x +ℤ (y +ℤ z)"
proof-
  have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Addition: Definition 1.4.1.b.›

lemma vint_commutative_law_addition: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘"    
  shows "x +ℤ y = y +ℤ x"
proof-
  have "x' + y' = y' + x'" for x' y' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for Addition: Definition 1.4.1.c.›

lemma vint_identity_law_addition: 
  assumes [simp]: "x ∈∘ ℤ∘"
  shows "x +ℤ 0ℤ = x"
proof-
  have "x' + 0 = x'" for x' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Inverses Law for Addition: Definition 1.4.1.d.›

lemma vint_inverses_law_addition: 
  assumes [simp]: "x ∈∘ ℤ∘"
  shows "x +ℤ (-ℤ x) = 0ℤ"
proof-
  have "x' + (-x') = 0" for x' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Multiplication: Definition 1.4.1.e.›

lemma vint_assoc_law_multiplication: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" and "z ∈∘ ℤ∘"  
  shows "(x *ℤ y) *ℤ z = x *ℤ (y *ℤ z)"
proof-
  have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Multiplication: Definition 1.4.1.f.›

lemma vint_commutative_law_multiplication: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" 
  shows "x *ℤ y = y *ℤ x"
proof-
  have "x' * y' = y' * x'" for x' y' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for multiplication: Definition 1.4.1.g.›

lemma vint_identity_law_multiplication: 
  assumes "x ∈∘ ℤ∘"
  shows "x *ℤ 1ℤ = x"
proof-
  have "x' * 1 = x'" for x' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Distributive Law for Multiplication: Definition 1.4.1.h.›

lemma vint_distributive_law: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" and "z ∈∘ ℤ∘"  
  shows "x *ℤ (y +ℤ z) = (x *ℤ y) +ℤ (x *ℤ z)"
proof-
  have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: int 
    by (simp add: algebra_simps)
  from this[untransferred, OF assms] show ?thesis.
qed


text‹No Zero Divisors Law: Definition 1.4.1.i.›

lemma vint_no_zero_divisors_law: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" and "x *ℤ y = 0ℤ"
  shows "x = 0ℤ ∨ y = 0ℤ" 
proof-
  have "x' * y' = 0 ⟹ x' = 0 ∨ y' = 0" for x' y' z' :: int 
    by (simp add: algebra_simps)
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Trichotomy Law: Definition 1.4.1.j›

lemma vint_trichotomy_law:
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘"
  shows 
    "(x <ℤ y ∧ ~(x = y) ∧ ~(y <ℤ x)) ∨ 
    (~(x <ℤ y) ∧ x = y ∧ ~(y <ℤ x)) ∨
    (~(x <ℤ y) ∧ ~(x = y) ∧ y <ℤ x)"
proof-
  have
    "(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨ 
    (~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
    (~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
    for x' y' z' :: int
    by auto
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Transitive Law: Definition 1.4.1.k›

lemma vint_transitive_law:
  assumes "x ∈∘ ℤ∘" 
    and "y ∈∘ ℤ∘" 
    and "z ∈∘ ℤ∘" 
    and "x <ℤ y" 
    and "y <ℤ z"
  shows "x <ℤ z"
proof-
  have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Addition Law of Order: Definition 1.4.1.l›

lemma vint_addition_law_of_order:
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘" and "z ∈∘ ℤ∘" and "x <ℤ y"
  shows "x +ℤ z <ℤ y +ℤ z"
proof-
  have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Multiplication Law of Order: Definition 1.4.1.m›

lemma vint_multiplication_law_of_order:
  assumes "x ∈∘ ℤ∘" 
    and "y ∈∘ ℤ∘" 
    and "z ∈∘ ℤ∘" 
    and "x <ℤ y"
    and "0ℤ <ℤ z"
  shows "x *ℤ z <ℤ y *ℤ z"
proof-
  have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Non-Triviality: Definition 1.4.1.n›

lemma vint_non_triviality: "0ℤ ≠ 1ℤ"
proof-
  have "0 ≠ (1::int)" by simp
  from this[untransferred] show ?thesis.
qed


text‹Well-Ordering Principle.›

lemma well_ordering_principle:
  assumes "A ⊆∘ ℤ∘" 
    and "a ∈∘ ℤ∘" 
    and "A ≠ 0" 
    and "⋀x. x ∈∘ A ⟹ a <ℤ x"
  obtains b where "b ∈∘ A" and "⋀x. x ∈∘ A ⟹ b ≤ℤ x"
proof-
  {
    fix A' and a' :: int assume prems: "A' ≠ {}" "x ∈ A' ⟹ a' < x" for x
    then obtain a'' where a'': "a'' ∈ A'" by auto
    from wfE_min[OF wf_int_ge_less_than[of a'], OF a''] obtain b'
      where b'_A': "b' ∈ A'" 
        and yb': "(y, b') ∈ int_ge_less_than a' ⟹ y ∉ A'" 
      for y
      by auto
    moreover from prems b'_A' yb' have "⋀x. x ∈ A' ⟹ b' ≤ x" 
      unfolding int_ge_less_than_def by fastforce
    with b'_A' have "∃b. b ∈ A' ∧ (∀x. x ∈ A' ⟶ b ≤ x)" by blast
  }
  note real_wo = this
  from real_wo[
      untransferred, of ‹elts A›, unfolded vnumber_simps, OF assms(1,2)
      ]
  obtain b 
    where "b ∈∘ ℤ∘" 
      and "b ∈∘ A" 
      and "⋀x. x ∈∘ ℤ∘ ⟹ x ∈∘ A ⟹ b ≤ℤ x"
    by (auto simp: assms(3,4))
  with assms that show ?thesis unfolding vsubset_iff by simp
qed


subsubsection‹Fundamental properties of other operations›


text‹Minus.›

lemma vint_minus_closed: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘"
  shows "x -ℤ y ∈∘ ℤ∘"
proof-
  have "x' - y' ∈ UNIV" for x' y' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vint_minus_eq_plus_uminus: 
  assumes "x ∈∘ ℤ∘" and "y ∈∘ ℤ∘"
  shows "x -ℤ y = x +ℤ (-ℤ y)"
proof-
  have "x' - y' = x' + (-y')" for x' y' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Unary minus.›

lemma vint_uminus_uminus: 
  assumes "x ∈∘ ℤ∘" 
  shows "x = -ℤ (-ℤ x)"
proof-
  have "x' = -(-x')" for x' :: int by simp
  from this[untransferred, OF assms] show ?thesis.
qed


subsubsection‹Further properties›


text‹Addition.›

global_interpretation vint_plus: binop_onto ‹ℤ∘› vint_plus
proof-
  have binop: "binop ℤ∘ vint_plus"
  proof(intro binopI nopI)
    show vsv: "vsv vint_plus" unfolding vint_plus_def by auto
    interpret vsv vint_plus by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vint_plus = ℤ∘ ^× 2ℕ" unfolding vint_plus_def by simp
    show "ℛ∘ vint_plus ⊆∘ ℤ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vint_plus"
      then obtain ab where "ab ∈∘ ℤ∘ ^× 2ℕ" and y_def: "y = vint_plus⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℤ∘" and b: "b ∈∘ ℤ∘"
        by blast
      then show "y ∈∘ ℤ∘" by (simp add: vint_plus_closed y_def)
    qed
  qed
  interpret binop ‹ℤ∘› vint_plus by (rule binop)
  show "binop_onto ℤ∘ vint_plus"
  proof(intro binop_ontoI')
    show "binop ℤ∘ vint_plus" by (rule binop_axioms)
    show "ℤ∘ ⊆∘ ℛ∘ vint_plus"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℤ∘"
      moreover from vint_zero vint_zero_closed have "0 ∈∘ ℤ∘" by auto
      ultimately have "y +ℤ 0 ∈∘ ℛ∘ vint_plus" by auto
      moreover from prems vint_identity_law_addition have "y = y +ℤ 0" 
        by (simp add: vint_zero)
      ultimately show "y ∈∘ ℛ∘ vint_plus" by simp
    qed
  qed
qed


text‹Unary minus.›

global_interpretation vint_uminus: v11 vint_uminus
  rewrites "𝒟∘ vint_uminus = ℤ∘"
    and "ℛ∘ vint_uminus = ℤ∘"
proof-
  show v11: "v11 vint_uminus" 
  proof(intro v11I)
    show vsv: "vsv vint_uminus" unfolding vint_uminus_def by simp
    interpret vsv vint_uminus by (rule vsv)
    show "vsv (vint_uminus¯∘)"
    proof(intro vsvI)
      show "vbrelation (vint_uminus¯∘)" by clarsimp
      fix a b c
      assume prems: "⟨a, b⟩ ∈∘ vint_uminus¯∘" "⟨a, c⟩ ∈∘ vint_uminus¯∘"
      then have ba: "⟨b, a⟩ ∈∘ vint_uminus" and ca: "⟨c, a⟩ ∈∘ vint_uminus" 
        by auto
      then have b: "b ∈∘ ℤ∘" and c: "c ∈∘ ℤ∘" 
        by (simp_all add: VLambda_iff2 vint_uminus_def)
      from ba ca have "a = -ℤ b" "a = -ℤ c" by simp_all
      with ba ca b c show "b = c"  by (metis vint_uminus_uminus)
    qed
  qed
  interpret v11 vint_uminus by (rule v11)
  show dom: "𝒟∘ vint_uminus = ℤ∘" unfolding vint_uminus_def by simp
  have "ℛ∘ vint_uminus ⊆∘ ℤ∘"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ vint_uminus"
    then obtain x where "x ∈∘ ℤ∘" and y_def: "y = -ℤ x" 
      unfolding dom[symmetric] by force
    then show "y ∈∘ ℤ∘" by (simp add: vint_uminus_closed)
  qed
  moreover have "ℤ∘ ⊆∘ ℛ∘ vint_uminus"
    by (intro vsubsetI) 
      (metis dom vdomain_atD vint_uminus_closed vint_uminus_uminus)
  ultimately show "ℛ∘ vint_uminus = ℤ∘" by simp
qed


text‹Multiplication.›

global_interpretation vint_mult: binop_onto ‹ℤ∘› vint_mult
proof-
  have binop: "binop ℤ∘ vint_mult"
  proof(intro binopI nopI)
    show vsv: "vsv vint_mult" unfolding vint_mult_def by auto
    interpret vsv vint_mult by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vint_mult = ℤ∘ ^× 2ℕ" unfolding vint_mult_def by simp
    show "ℛ∘ vint_mult ⊆∘ ℤ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vint_mult"
      then obtain ab where "ab ∈∘ ℤ∘ ^× 2ℕ" and y_def: "y = vint_mult⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℤ∘" and b: "b ∈∘ ℤ∘"
        by blast
      then show "y ∈∘ ℤ∘" by (simp add: vint_mult_closed y_def)
    qed
  qed
  interpret binop ‹ℤ∘› vint_mult by (rule binop)
  show "binop_onto ℤ∘ vint_mult"
  proof(intro binop_ontoI')
    show "binop ℤ∘ vint_mult" by (rule binop_axioms)
    show "ℤ∘ ⊆∘ ℛ∘ vint_mult"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℤ∘"
      moreover from vint_one vint_one_closed have 0: "1 ∈∘ ℤ∘" by auto
      ultimately have "y *ℤ 1 ∈∘ ℛ∘ vint_mult" by auto
      moreover from prems vint_identity_law_multiplication have "y = y *ℤ 1" 
        by (simp add: vint_one)
      ultimately show "y ∈∘ ℛ∘ vint_mult" by simp
    qed
  qed
qed



subsection‹Rational numbers›


subsubsection‹Definition›

definition vrat_of_rat :: "rat ⇒ V"
  where "vrat_of_rat x = vreal_of_real (real_of_rat x)"

notation vrat_of_rat (‹_ℚ› [999] 999)

declare [[coercion "vrat_of_rat :: rat ⇒ V"]]

definition vrat :: V (‹ℚ∘›)
  where "vrat = set (range vrat_of_rat)"

definition rat_of_vrat :: "V ⇒ rat"
  where "rat_of_vrat = inv_into UNIV vrat_of_rat"


text‹Rules.›

lemma vrat_of_rat_in_vratI[intro, simp]: "aℚ ∈∘ ℚ∘" by (simp add: vrat_def)

lemma vrat_of_rat_in_vratE[elim]:
  assumes "a ∈∘ ℚ∘"
  obtains b where "bℚ = a"
  using assms unfolding vrat_def by auto


subsubsection‹Elementary properties›

lemma vrat_vsubset_vreal: "ℚ∘ ⊆∘ ℝ∘"
  unfolding vrat_def vrat_of_rat_def vreal_def using image_cong by auto

lemma vrat_in_Vset_ω2: "ℚ∘ ∈∘ Vset (ω + ω)"
  using vrat_vsubset_vreal vreal_in_Vset_ω2 by auto

lemma inj_vrat_of_rat: "inj vrat_of_rat"
  using inj_vreal_of_real 
  unfolding vrat_of_rat_def inj_def of_rat_eq_iff
  by force

lemma rat_of_vrat_vrat_of_rat[simp]: "rat_of_vrat (aℚ) = a"
  by (simp add: inj_vrat_of_rat rat_of_vrat_def)


text‹Transfer rules.›

definition cr_vrat :: "V ⇒ rat ⇒ bool"
  where "cr_vrat a b ⟷ (a = vrat_of_rat b)"

lemma cr_vrat_right_total[transfer_rule]: "right_total cr_vrat"
  unfolding cr_vrat_def right_total_def by simp

lemma cr_vrat_bi_unqie[transfer_rule]: "bi_unique cr_vrat"
  unfolding cr_vrat_def bi_unique_def
  by (simp add: inj_eq inj_vrat_of_rat)

lemma cr_vrat_transfer_domain_rule[transfer_domain_rule]: 
  "Domainp cr_vrat = (λx. x ∈∘ ℚ∘)"
  unfolding cr_vrat_def by force

lemma vrat_transfer[transfer_rule]: 
  "(rel_set cr_vrat) (elts ℚ∘) (UNIV::rat set)"
  unfolding cr_vrat_def rel_set_def by auto

lemma vrat_of_rat_transfer[transfer_rule]: "cr_vrat (vrat_of_rat a) a"
  unfolding cr_vrat_def by auto


subsubsection‹Operations›

lemma vrat_fsingleton_in_fproduct_vrat: "[aℚ]∘ ∈∘ ℚ∘ ^× 1ℕ" by auto

lemma vrat_fpair_in_fproduct_vrat: "[aℚ, bℚ]∘ ∈∘ ℚ∘ ^× 2ℕ" by force


text‹Zero.›

lemma vrat_zero: "0ℚ = (0::V)" by (simp add: vrat_of_rat_def vreal_zero)


text‹One.›

lemma vrat_one: "1ℚ = (1::V)" by (simp add: vreal_one vrat_of_rat_def)
  

text‹Addition.›

definition vrat_plus :: V 
  where "vrat_plus = 
    (λx∈∘ℚ∘ ^× 2ℕ. (rat_of_vrat (x⦇0ℕ⦈) + rat_of_vrat (x⦇1ℕ⦈))ℚ)"

abbreviation vrat_plus_app (infixl "+ℚ" 65) 
  where "vrat_plus_app a b ≡ vrat_plus⦇a, b⦈∙"

lemma vrat_plus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat ===> cr_vrat) (+ℚ) (+)"
  using vrat_fpair_in_fproduct_vrat
  by (intro rel_funI, unfold vrat_plus_def cr_vrat_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Multiplication.›

definition vrat_mult :: V 
  where "vrat_mult =
    (λx∈∘ℚ∘ ^× 2ℕ. (rat_of_vrat (x⦇0ℕ⦈) * rat_of_vrat (x⦇1ℕ⦈))ℚ)"

abbreviation vrat_mult_app (infixl "*ℚ" 65) 
  where "vrat_mult_app a b ≡ vrat_mult⦇a, b⦈∙"

lemma vrat_mult_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat ===> cr_vrat) (*ℚ) (*)"
  using vrat_fpair_in_fproduct_vrat
  by (intro rel_funI, unfold vrat_mult_def cr_vrat_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Unary minus.›

definition vrat_uminus :: V 
  where "vrat_uminus = (λx∈∘ℚ∘. (uminus (rat_of_vrat x))ℚ)"

abbreviation vrat_uminus_app ("-ℚ _" [81] 80) 
  where "-ℚ a ≡ vrat_uminus⦇a⦈"

lemma vrat_uminus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat) (vrat_uminus_app) (uminus)"
  using vrat_fsingleton_in_fproduct_vrat 
  by (intro rel_funI, unfold vrat_uminus_def cr_vrat_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Multiplicative inverse.›

definition vrat_inverse :: V 
  where "vrat_inverse = (λx∈∘ℚ∘. (inverse (rat_of_vrat x))ℚ)"

abbreviation vrat_inverse_app ("(_¯ℚ)" [1000] 999) 
  where "a¯ℚ ≡ vrat_inverse⦇a⦈"

lemma vrat_inverse_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat) (vrat_inverse_app) (inverse)"
  using vrat_fsingleton_in_fproduct_vrat 
  by (intro rel_funI, unfold vrat_inverse_def cr_vrat_def cr_scalar_def) 
    (simp add: nat_omega_simps)


text‹Order.›

definition vrat_le :: V 
  where "vrat_le =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ ∧ rat_of_vrat a ≤ rat_of_vrat b}"

abbreviation vrat_le' ("(_/ ≤ℚ _)"  [51, 51] 50)
  where "a ≤ℚ b ≡ [a, b]∘ ∈∘ vrat_le"

lemma small_vrat_le[simp]: 
  "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ ∧ rat_of_vrat a ≤ rat_of_vrat b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vrat_le_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat ===> (=)) vrat_le' (≤)"
  using vrat_fsingleton_in_fproduct_vrat 
  by (intro rel_funI, unfold cr_scalar_def cr_vrat_def vrat_le_def)
    (auto simp: nat_omega_simps)


text‹Strict order.›

definition vrat_ls :: V 
  where "vrat_ls =
    set {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ ∧ rat_of_vrat a < rat_of_vrat b}"

abbreviation vrat_ls' ("(_/ <ℚ _)"  [51, 51] 50)
  where "a <ℚ b ≡ [a, b]∘ ∈∘ vrat_ls"

lemma small_vrat_ls[simp]: 
  "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ ∧ rat_of_vrat a < rat_of_vrat b}"
proof-
  have small: "small {[a, b]∘ | a b. [a, b]∘ ∈∘ ℚ∘ ^× 2ℕ}" by simp
  show ?thesis by (rule smaller_than_small[OF small]) auto
qed

lemma vrat_ls_transfer[transfer_rule]:
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat ===> (=)) vrat_ls' (<)"
  by (intro rel_funI, unfold cr_scalar_def cr_vrat_def vrat_ls_def)
    (auto simp: nat_omega_simps)
  

text‹Subtraction.›

definition vrat_minus :: V 
  where "vrat_minus = 
    (λx∈∘ℚ∘ ^× 2ℕ. (rat_of_vrat (x⦇0ℕ⦈) - rat_of_vrat (x⦇1ℕ⦈))ℚ)"

abbreviation vrat_minus_app (infixl "-ℚ" 65) 
  where "vrat_minus_app a b ≡ vrat_minus⦇a, b⦈∙"

lemma vrat_minus_transfer[transfer_rule]: 
  includes lifting_syntax
  shows "(cr_vrat ===> cr_vrat ===> cr_vrat)
    (-ℚ) (-)"
  using vrat_fpair_in_fproduct_vrat 
  by (intro rel_funI, unfold vrat_minus_def cr_vrat_def cr_scalar_def) 
    (simp add: nat_omega_simps)


subsubsection‹Axioms of an ordered field›


text‹The exposition follows Theorem 1.5.5 from the textbook
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.›

lemma vrat_zero_closed: "0ℚ ∈∘ ℚ∘" by auto

lemma vrat_one_closed: "1ℚ ∈∘ ℚ∘" by auto

lemma vrat_plus_closed: 
  assumes "x ∈∘ ℚ∘" "y ∈∘ ℚ∘"
  shows "x +ℚ y ∈∘ ℚ∘"
proof-
  have "x' + y' ∈ UNIV" for x' y' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vrat_mult_closed:
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" 
  shows "x *ℚ y ∈∘ ℚ∘"
proof-
  have "(x'::rat) * y' ∈ UNIV" for x' y' by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vrat_uminus_closed: 
  assumes "x ∈∘ ℚ∘"
  shows "-ℚ x ∈∘ ℚ∘"
proof-
  have "(-x'::rat) ∈ UNIV" for x' by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vrat_inverse_closed: 
  assumes "x ∈∘ ℚ∘"
  shows "x¯ℚ ∈∘ ℚ∘"
proof-
  have "inverse (x'::rat) ∈ UNIV" for x' by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Addition: Theorem 1.5.5.1.›

lemma vrat_assoc_law_addition: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" and "z ∈∘ ℚ∘"  
  shows "(x +ℚ y) +ℚ z = x +ℚ (y +ℚ z)"
proof-
  have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Addition: Theorem 1.5.5.2.›

lemma vrat_commutative_law_addition: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘"    
  shows "x +ℚ y = y +ℚ x"
proof-
  have "x' + y' = y' + x'" for x' y' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for Addition: Theorem 1.5.5.3.›

lemma vrat_identity_law_addition: 
  assumes [simp]: "x ∈∘ ℚ∘"
  shows "x +ℚ 0ℚ = x"
proof-
  have "x' + 0 = x'" for x' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Inverses Law for Addition: Theorem 1.5.5.4.›

lemma vrat_inverses_law_addition: 
  assumes [simp]: "x ∈∘ ℚ∘"
  shows "x +ℚ (-ℚ x) = 0ℚ"
proof-
  have "x' + (-x') = 0" for x' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Associative Law for Multiplication: Theorem 1.5.5.5.›

lemma vrat_assoc_law_multiplication: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" and "z ∈∘ ℚ∘"  
  shows "(x *ℚ y) *ℚ z = x *ℚ (y *ℚ z)"
proof-
  have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Commutative Law for Multiplication: Theorem 1.5.5.6.›

lemma vrat_commutative_law_multiplication: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" 
  shows "x *ℚ y = y *ℚ x"
proof-
  have "x' * y' = y' * x'" for x' y' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Identity Law for multiplication: Theorem 1.5.5.7.›

lemma vrat_identity_law_multiplication: 
  assumes "x ∈∘ ℚ∘"
  shows "x *ℚ 1ℚ = x"
proof-
  have "x' * 1 = x'" for x' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Inverses Law for Multiplication: Definition 2.2.1.8.›

lemma vrat_inverses_law_multiplication:
  assumes "x ∈∘ ℚ∘" and "x ≠ 0ℚ" 
  shows "x *ℚ x¯ℚ = 1ℚ"
proof-
  have "x' ≠ 0 ⟹ x' * inverse x' = 1" for x' :: rat by simp  
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Distributive Law for Multiplication: Theorem 1.5.5.9.›

lemma vrat_distributive_law: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" and "z ∈∘ ℚ∘"  
  shows "x *ℚ (y +ℚ z) = (x *ℚ y) +ℚ (x *ℚ z)"
proof-
  have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: rat 
    by (simp add: algebra_simps)
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Trichotomy Law: Theorem 1.5.5.10.›

lemma vrat_trichotomy_law:
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘"
  shows 
    "(x <ℚ y ∧ ~(x = y) ∧ ~(y <ℚ x)) ∨ 
    (~(x <ℚ y) ∧ x = y ∧ ~(y <ℚ x)) ∨
    (~(x <ℚ y) ∧ ~(x = y) ∧ y <ℚ x)"
proof-
  have
    "(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨ 
    (~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
    (~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
    for x' y' z' :: rat
    by auto
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Transitive Law: Theorem 1.5.5.11.›

lemma vrat_transitive_law:
  assumes "x ∈∘ ℚ∘" 
    and "y ∈∘ ℚ∘" 
    and "z ∈∘ ℚ∘" 
    and "x <ℚ y" 
    and "y <ℚ z"
  shows "x <ℚ z"
proof-
  have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Addition Law of Order: Theorem 1.5.5.12.›

lemma vrat_addition_law_of_order:
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘" and "z ∈∘ ℚ∘" and "x <ℚ y"
  shows "x +ℚ z <ℚ y +ℚ z"
proof-
  have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Multiplication Law of Order: Theorem 1.5.5.13.›

lemma vrat_multiplication_law_of_order:
  assumes "x ∈∘ ℚ∘" 
    and "y ∈∘ ℚ∘" 
    and "z ∈∘ ℚ∘" 
    and "x <ℚ y"
    and "0ℚ <ℚ z"
  shows "x *ℚ z <ℚ y *ℚ z"
proof-
  have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Non-Triviality: Theorem 1.5.5.14.›

lemma vrat_non_triviality: "0ℚ ≠ 1ℚ"
proof-
  have "0 ≠ (1::rat)" by simp
  from this[untransferred] show ?thesis.
qed


subsubsection‹Fundamental properties of other operations›


text‹Minus.›

lemma vrat_minus_closed: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘"
  shows "x -ℚ y ∈∘ ℚ∘"
proof-
  have "x' - y' ∈ UNIV" for x' y' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed

lemma vrat_minus_eq_plus_uminus: 
  assumes "x ∈∘ ℚ∘" and "y ∈∘ ℚ∘"
  shows "x -ℚ y = x +ℚ (-ℚ y)"
proof-
  have "x' - y' = x' + (-y')" for x' y' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Unary minus.›

lemma vrat_uminus_uminus: 
  assumes "x ∈∘ ℚ∘" 
  shows "x = -ℚ (-ℚ x)"
proof-
  have "x' = -(-x')" for x' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


text‹Multiplicative inverse.›

lemma vrat_inverse_inverse: 
  assumes "x ∈∘ ℚ∘" 
  shows "x = (x¯ℚ)¯ℚ"
proof-
  have "x' = inverse (inverse x')" for x' :: rat by simp
  from this[untransferred, OF assms] show ?thesis.
qed


subsubsection‹Further properties›


text‹Addition.›

global_interpretation vrat_plus: binop_onto ‹ℚ∘› vrat_plus
proof-
  have binop: "binop ℚ∘ vrat_plus"
  proof(intro binopI nopI)
    show vsv: "vsv vrat_plus" unfolding vrat_plus_def by auto
    interpret vsv vrat_plus by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vrat_plus = ℚ∘ ^× 2ℕ" unfolding vrat_plus_def by simp
    show "ℛ∘ vrat_plus ⊆∘ ℚ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vrat_plus"
      then obtain ab where "ab ∈∘ ℚ∘ ^× 2ℕ" and y_def: "y = vrat_plus⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℚ∘" and b: "b ∈∘ ℚ∘"
        by blast
      then show "y ∈∘ ℚ∘" by (simp add: vrat_plus_closed y_def)
    qed
  qed
  interpret binop ‹ℚ∘› vrat_plus by (rule binop)
  show "binop_onto ℚ∘ vrat_plus"
  proof(intro binop_ontoI')
    show "binop ℚ∘ vrat_plus" by (rule binop_axioms)
    show "ℚ∘ ⊆∘ ℛ∘ vrat_plus"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℚ∘"
      moreover from vrat_zero vrat_zero_closed have 0: "0 ∈∘ ℚ∘" 
        by auto
      ultimately have "y +ℚ 0 ∈∘ ℛ∘ vrat_plus" by auto
      moreover from prems vrat_identity_law_addition have "y = y +ℚ 0" 
        by (simp add: vrat_zero)
      ultimately show "y ∈∘ ℛ∘ vrat_plus" by simp
    qed
  qed
qed


text‹Unary minus.›

global_interpretation vrat_uminus: v11 vrat_uminus
  rewrites "𝒟∘ vrat_uminus = ℚ∘"
    and "ℛ∘ vrat_uminus = ℚ∘"
proof-
  show v11: "v11 vrat_uminus" 
  proof(intro v11I)
    show vsv: "vsv vrat_uminus" unfolding vrat_uminus_def by simp
    interpret vsv vrat_uminus by (rule vsv)
    show "vsv (vrat_uminus¯∘)"
    proof(intro vsvI)
      show "vbrelation (vrat_uminus¯∘)" by clarsimp
      fix a b c
      assume prems: "⟨a, b⟩ ∈∘ vrat_uminus¯∘" "⟨a, c⟩ ∈∘ vrat_uminus¯∘"
      then have ba: "⟨b, a⟩ ∈∘ vrat_uminus" and ca: "⟨c, a⟩ ∈∘ vrat_uminus" 
        by auto
      then have b: "b ∈∘ ℚ∘" and c: "c ∈∘ ℚ∘" 
        by (simp_all add: VLambda_iff2 vrat_uminus_def)
      from ba ca have "a = -ℚ b" "a = -ℚ c" by simp_all
      with ba ca b c show "b = c"  by (metis vrat_uminus_uminus)
    qed
  qed
  interpret v11 vrat_uminus by (rule v11)
  show dom: "𝒟∘ vrat_uminus = ℚ∘" unfolding vrat_uminus_def by simp
  have "ℛ∘ vrat_uminus ⊆∘ ℚ∘"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ vrat_uminus"
    then obtain x where "x ∈∘ ℚ∘" and y_def: "y = -ℚ x" 
      unfolding dom[symmetric] by force
    then show "y ∈∘ ℚ∘" by (simp add: vrat_uminus_closed)
  qed
  moreover have "ℚ∘ ⊆∘ ℛ∘ vrat_uminus"
    by (intro vsubsetI) 
      (metis dom vdomain_atD vrat_uminus_closed vrat_uminus_uminus)
  ultimately show "ℛ∘ vrat_uminus = ℚ∘" by simp
qed


text‹Multiplication.›

global_interpretation vrat_mult: binop_onto ‹ℚ∘› vrat_mult
proof-
  have binop: "binop ℚ∘ vrat_mult"
  proof(intro binopI nopI)
    show vsv: "vsv vrat_mult" unfolding vrat_mult_def by auto
    interpret vsv vrat_mult by (rule vsv)
    show "2ℕ ∈∘ ω" by simp
    show dom: "𝒟∘ vrat_mult = ℚ∘ ^× 2ℕ" unfolding vrat_mult_def by simp
    show "ℛ∘ vrat_mult ⊆∘ ℚ∘"
    proof(intro vsubsetI)
      fix y assume "y ∈∘ ℛ∘ vrat_mult"
      then obtain ab where "ab ∈∘ ℚ∘ ^× 2ℕ" and y_def: "y = vrat_mult⦇ab⦈" 
        unfolding dom[symmetric] by force
      then obtain a b 
        where ab_def: "ab = [a, b]∘" and a: "a ∈∘ ℚ∘" and b: "b ∈∘ ℚ∘"
        by blast
      then show "y ∈∘ ℚ∘" by (simp add: vrat_mult_closed y_def)
    qed
  qed
  interpret binop ‹ℚ∘› vrat_mult by (rule binop)
  show "binop_onto ℚ∘ vrat_mult"
  proof(intro binop_ontoI')
    show "binop ℚ∘ vrat_mult" by (rule binop_axioms)
    show "ℚ∘ ⊆∘ ℛ∘ vrat_mult"
    proof(intro vsubsetI)
      fix y assume prems: "y ∈∘ ℚ∘"
      moreover from vrat_one vrat_one_closed have "1 ∈∘ ℚ∘" by auto
      ultimately have "y *ℚ 1 ∈∘ ℛ∘ vrat_mult" by auto
      moreover from prems vrat_identity_law_multiplication have "y = y *ℚ 1" 
        by (simp add: vrat_one)
      ultimately show "y ∈∘ ℛ∘ vrat_mult" by simp
    qed
  qed
qed


text‹Multiplicative inverse.›

global_interpretation vrat_inverse: v11 vrat_inverse
  rewrites "𝒟∘ vrat_inverse = ℚ∘"
    and "ℛ∘ vrat_inverse = ℚ∘"
proof-
  show v11: "v11 vrat_inverse" 
  proof(intro v11I)
    show vsv: "vsv vrat_inverse" unfolding vrat_inverse_def by simp
    interpret vsv vrat_inverse by (rule vsv)
    show "vsv (vrat_inverse¯∘)"
    proof(intro vsvI)
      show "vbrelation (vrat_inverse¯∘)" by clarsimp
      fix a b c
      assume prems: "⟨a, b⟩ ∈∘ vrat_inverse¯∘" "⟨a, c⟩ ∈∘ vrat_inverse¯∘"
      then have ba: "⟨b, a⟩ ∈∘ vrat_inverse" and ca: "⟨c, a⟩ ∈∘ vrat_inverse" 
        by auto
      then have b: "b ∈∘ ℚ∘" and c: "c ∈∘ ℚ∘" 
        by (simp_all add: VLambda_iff2 vrat_inverse_def)
      from ba ca have "a = b¯ℚ" "a = c¯ℚ" by simp_all
      with ba ca b c show "b = c"  by (metis vrat_inverse_inverse)
    qed
  qed
  interpret v11 vrat_inverse by (rule v11)
  show dom: "𝒟∘ vrat_inverse = ℚ∘" unfolding vrat_inverse_def by simp
  have "ℛ∘ vrat_inverse ⊆∘ ℚ∘"
  proof(intro vsubsetI)
    fix y assume "y ∈∘ ℛ∘ vrat_inverse"
    then obtain x where "x ∈∘ ℚ∘" and y_def: "y = x¯ℚ" 
      unfolding dom[symmetric] by force
    then show "y ∈∘ ℚ∘" by (simp add: vrat_inverse_closed)
  qed
  moreover have "ℚ∘ ⊆∘ ℛ∘ vrat_inverse"
    by (intro vsubsetI) 
      (metis dom vdomain_atD vrat_inverse_closed vrat_inverse_inverse)
  ultimately show "ℛ∘ vrat_inverse = ℚ∘" by simp
qed



subsection‹Upper bound on the cardinality of the continuum for typ‹V››

lemma inj_on_inv_vreal_of_real: "inj_on (inv vreal_of_real) (elts ℝ∘)"
  by (intro inj_onI) (fastforce intro: inv_into_injective)

lemma vreal_vlepoll_VPow_omega: "ℝ∘ ≲∘ VPow ω"
proof-
  have "elts ℝ∘ ≲ (UNIV::real set)"
    unfolding lepoll_def by (auto intro: inj_on_inv_vreal_of_real)
  from vlepoll_VPow_omega_if_vreal_lepoll_real[OF this] show ?thesis by simp
qed

text‹\newpage›

end

Theory CZH_EX_Replacement

(* Copyright 2021 (C) Mihails Milehins *)

section‹Example I: absence of replacement in ‹Vω+ω››
theory CZH_EX_Replacement
  imports CZH_Sets_ZQR
begin


text‹
The statement of the main result presented in this subsection
can be found in \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Zermelo_set_theory}
}
›

definition repl_ex_fun :: V
  where "repl_ex_fun = (λi∈∘ω. Vfrom ω i)"

mk_VLambda repl_ex_fun_def
  |vsv repl_ex_fun_vsv|
  |vdomain repl_ex_fun_vdomain|
  |app repl_ex_fun_app|

lemma repl_ex_fun_vrange: "ℛ∘ repl_ex_fun ⊆∘ Vset (ω + ω)"
proof(intro vsv.vsv_vrange_vsubset, unfold repl_ex_fun_vdomain)
  fix x assume prems: "x ∈∘ ω"
  then show "repl_ex_fun⦇x⦈ ∈∘ Vset (ω + ω)"
  proof(induction rule: omega_induct)
    case 0 then show ?case 
      by 
        (
          auto 
            simp: repl_ex_fun_app intro!: vreal_in_Vset_ω2 omega_vsubset_vreal
        )
  next
    case (succ n)
    then have Ord_n: "Ord n" by auto
    have Limit_ωω: "Limit (ω + ω)" by auto
    from succ show ?case 
      by
        (
          auto 
            simp: Vfrom_succ_Ord[OF Ord_n, of ω] repl_ex_fun_app 
            intro: Limit_ωω 
            intro!: omega_vsubset_vreal vreal_in_Vset_ω2
        )
  qed
qed (unfold repl_ex_fun_def, auto)

lemma Limit_vsv_not_in_Vset_if_vrange_not_in_Vset:
  assumes "Limit α" and "ℛ∘ f ∉∘ Vset α"
  shows "f ∉∘ Vset α"
proof(rule ccontr, unfold not_not)
  assume "f ∈∘ Vset α"
  with assms(1) have "ℛ∘ f ∈∘ Vset α" by (simp add: vrange_in_VsetI)
  with assms(2) show False by simp
qed

lemma Ord_not_in_Vset:
  assumes "Ord α"
  shows "α ∉∘ Vset α"
  using assms
proof(induction rule: Ord_induct3')
  case (succ α)
  then have succα: "Vset (succ α) = VPow (Vset α)" by (simp add: Vset_succ)
  show ?case 
  proof(rule ccontr, unfold not_not)
    assume "succ α ∈∘ Vset (succ α)"
    then have "vinsert α α ∈∘ VPow (Vset α)" 
      unfolding succα by (simp add: succ_def)
    with succ(2) show False by auto
  qed
next
  case (Limit α) show ?case 
  proof(rule ccontr, unfold not_not)
    assume "(⋃∘ξ∈∘α. ξ) ∈∘ Vset (⋃∘ξ∈∘α. ξ)"
    with Limit(1) have "α ∈∘ Vset α" by auto
    with Limit(1) obtain i where i: "i ∈∘ α" and "(⋃∘ξ∈∘α. ξ) ∈∘ Vset i" 
      by (metis Limit_Vfrom_eq Limit_vifunion_def vifunion_iff)
    moreover with Limit(1) have "α ∈∘ Vset i" by auto
    ultimately have "i ∈∘ Vset i" by auto
    with Limit(2)[OF i] show False by auto
  qed
qed simp

lemma Ord_succ_vsusbset_Vfrom_succ: 
  assumes "Transset A" and "Ord a" and "a ∈∘ Vfrom A i" 
  shows "succ a ⊆∘ Vfrom A (succ i)"
proof(intro vsubsetI)
  from Vfrom_in_mono[OF vsubset_reflexive] have i_succi: 
    "Vfrom A i ∈∘ Vfrom A (succ i)"
    by simp
  fix x assume prems: "x ∈∘ succ a"
  then consider ‹x ∈∘ a› | ‹x = a› unfolding succ_def by auto
  then show "x ∈∘ Vfrom A (succ i)"
  proof cases
    case 1
    have "x ∈∘ Vfrom A i" by (rule Vfrom_trans[OF assms(1) 1 assms(3)])
    then show "x ∈∘ Vfrom A (succ i)" by (rule Vfrom_trans[OF assms(1) _ i_succi])
  next
    case 2 from assms(3) show ?thesis
      unfolding 2 by (intro Vfrom_trans[OF assms(1) _ i_succi])
  qed
qed

lemma Ord_succ_in_Vfrom_succ: 
  assumes "Transset A" and "Ord a" and "a ∈∘ Vfrom A i" 
  shows "succ a ∈∘ Vfrom A (succ (succ i))"
  using Ord_succ_vsusbset_Vfrom_succ[OF assms] by (simp add: Vfrom_succ)

lemma ω_vplus_in_Vfrom_ω:
  assumes "j ∈∘ ω"
  shows "ω + j ∈∘ Vfrom ω (succ (2ℕ * j))"
  using assms
proof(induction rule: omega_induct)
  case 0
  have "ω ∈∘ Vfrom ω (succ 0)" 
    unfolding Vfrom_succ_Ord[where i=0, simplified] by auto
  then show ?case by simp
next
  case (succ n)
  from succ(1) obtain m where n_def: "n = mℕ" by (auto elim: nat_of_omega)
  from succ(1) have ω_succn: "ω + succ n = succ (ω + n)" by (simp add: plus_V_succ_right)
  from succ(1) have succ_2succn: "succ (2ℕ * succ n) = succ (succ (succ (2ℕ * n)))" 
    unfolding n_def by (cs_concl_step nat_omega_simps)+ auto    
  show ?case 
    unfolding ω_succn succ_2succn
    by (intro Ord_succ_in_Vfrom_succ succ) 
      (auto simp: succ(1) intro: Ord_is_Transset)
qed

lemma repl_ex_fun_vrange_not_in_Vset: "ℛ∘ repl_ex_fun ∉∘ Vset (ω + ω)"
proof(rule ccontr, unfold not_not)
  assume prems: "ℛ∘ repl_ex_fun ∈∘ Vset (ω + ω)"
  then have "⋃∘(ℛ∘ repl_ex_fun) ∈∘ Vset (ω + ω)" by (simp add: VUnion_in_VsetI)
  moreover have "ω + ω ⊆∘ ⋃∘(ℛ∘ repl_ex_fun)"
  proof(intro vsubsetI)
    fix x assume prems: "x ∈∘ ω + ω"
    from prems consider ‹x ∈∘ ω› | ‹x ∉∘ ω› by auto
    then show "x ∈∘ ⋃∘(ℛ∘ repl_ex_fun)"
    proof cases
      case 1 
      show ?thesis 
      proof(rule VUnionI)
        show "Vfrom ω 0 ∈∘ ℛ∘ repl_ex_fun"
          unfolding repl_ex_fun_def by blast
        from 1 show "x ∈∘ Vfrom ω 0" by auto
      qed
    next
      case 2
      with prems obtain j where x_def: "x = ω + j" and j: "j ∈∘ ω" 
        by (auto elim: mem_plus_V_E)
      show ?thesis
      proof(rule VUnionI)
        from j show "Vfrom ω (succ (2ℕ * j)) ∈∘ ℛ∘ repl_ex_fun"
          unfolding repl_ex_fun_def by blast
        show "x ∈∘ Vfrom ω (succ (2ℕ * j))"
          by (rule ω_vplus_in_Vfrom_ω[OF j, folded x_def])
      qed
    qed
  qed
  ultimately have "ω + ω ∈∘ Vset (ω + ω)" by auto
  with Ord_not_in_Vset show False by auto
qed

lemma repl_ex_fun_not_in_Vset: "repl_ex_fun ∉∘ Vset (ω + ω)"
  by (rule Limit_vsv_not_in_Vset_if_vrange_not_in_Vset) 
    (auto simp: repl_ex_fun_vrange_not_in_Vset)

text‹\newpage›

end

Theory CZH_EX_TS

(* Copyright 2021 (C) Mihails Milehins *)

section‹Example II: topological spaces›
theory CZH_EX_TS
  imports CZH_Sets_ZQR
begin



subsection‹Background›


text‹
The section presents elements of the foundations of the theory of topological
spaces formalized in ‹ZFC in HOL›. The definitions were adopted 
(with amendments) from the main library of Isabelle/HOL and 
\cite{kelley_general_nodate}.
›

named_theorems ts_struct_field_simps



subsection‹‹𝒵›-sequence›

locale 𝒵_vfsequence = 𝒵 α + vfsequence 𝔖 for α 𝔖 +
  assumes vrange_vsubset_Vset: "ℛ∘ 𝔖 ⊆∘ Vset α"


text‹Rules.›

lemma 𝒵_vfsequenceI[intro]:
  assumes "𝒵 α" and "vfsequence 𝔖" and "ℛ∘ 𝔖 ⊆∘ Vset α"
  shows "𝒵_vfsequence α 𝔖"
  using assms unfolding 𝒵_vfsequence_def 𝒵_vfsequence_axioms_def by simp

lemmas 𝒵_vfsequenceD[dest] = 𝒵_vfsequence.axioms

lemma 𝒵_vfsequenceE[elim]:
  assumes "𝒵_vfsequence α 𝔖"
  obtains "𝒵 α" and "vfsequence 𝔖" and "ℛ∘ 𝔖 ⊆∘ Vset α"
  using assms by (simp add: 𝒵_vfsequence.axioms(1,2) 𝒵_vfsequence.vrange_vsubset_Vset)
  

text‹Elementary properties.›

context 𝒵_vfsequence
begin

lemma (in 𝒵_vfsequence) 𝒵_vfsequence_vdomain_in_Vset[intro, simp]: 
  "𝒟∘ 𝔖 ∈∘ Vset α"
  using Axiom_of_Infinity vfsequence_vdomain_in_omega by auto

lemma (in 𝒵_vfsequence) 𝒵_vfsequence_vrange_in_Vset[intro, simp]: 
  "ℛ∘ 𝔖 ∈∘ Vset α"
  using vrange_vsubset_Vset vfsequence_vdomain_in_omega by auto

lemma (in 𝒵_vfsequence) 𝒵_vfsequence_struct_in_Vset: "𝔖 ∈∘ Vset α"
  by (auto simp: vrange_vsubset_Vset vsv_Limit_vsv_in_VsetI)

end


subsection‹Topological space›

definition 𝒜 where [ts_struct_field_simps]: "𝒜 = 0"
definition 𝒯 where [ts_struct_field_simps]: "𝒯 = 1ℕ"

locale 𝒵_ts = 𝒵_vfsequence α 𝔖 for α 𝔖 +
  assumes 𝒵_ts_length: "2ℕ ≤ vcard 𝔖" 
    and 𝒵_ts_closed[intro]: "A ∈∘ 𝔖⦇𝒯⦈ ⟹ A ⊆∘ 𝔖⦇𝒜⦈"
    and 𝒵_ts_domain[intro, simp]: "𝔖⦇𝒜⦈ ∈∘ 𝔖⦇𝒯⦈"
    and 𝒵_ts_vintersection[intro]: 
      "A ∈∘ 𝔖⦇𝒯⦈ ⟹ B ∈∘ 𝔖⦇𝒯⦈ ⟹ A ∩∘ B ∈∘ 𝔖⦇𝒯⦈"
    and 𝒵_ts_VUnion[intro]: "X ⊆∘ 𝔖⦇𝒯⦈ ⟹ ⋃∘X ∈∘ 𝔖⦇𝒯⦈"


text‹Rules.›

lemma 𝒵_tsI[intro]:
  assumes "𝒵_vfsequence α 𝔖"
    and "2ℕ ≤ vcard 𝔖"
    and "⋀A. A ∈∘ 𝔖⦇𝒯⦈ ⟹ A ⊆∘ 𝔖⦇𝒜⦈"
    and "𝔖⦇𝒜⦈ ∈∘ 𝔖⦇𝒯⦈"
    and "⋀A B. A ∈∘ 𝔖⦇𝒯⦈ ⟹ B ∈∘ 𝔖⦇𝒯⦈ ⟹ A ∩∘ B ∈∘ 𝔖⦇𝒯⦈"
    and "⋀X. X ⊆∘ 𝔖⦇𝒯⦈ ⟹ ⋃∘X ∈∘ 𝔖⦇𝒯⦈"
  shows "𝒵_ts α 𝔖"
  using assms unfolding 𝒵_ts_def 𝒵_ts_axioms_def by simp

lemma 𝒵_tsD[dest]:
  assumes "𝒵_ts α 𝔖"
  shows "𝒵_vfsequence α 𝔖"
    and "2ℕ ≤ vcard 𝔖"
    and "⋀A. A ∈∘ 𝔖⦇𝒯⦈ ⟹ A ⊆∘ 𝔖⦇𝒜⦈"
    and "𝔖⦇𝒜⦈ ∈∘ 𝔖⦇𝒯⦈"
    and "⋀A B. A ∈∘ 𝔖⦇𝒯⦈ ⟹ B ∈∘ 𝔖⦇𝒯⦈ ⟹ A ∩∘ B ∈∘ 𝔖⦇𝒯⦈"
    and "⋀X. X ⊆∘ 𝔖⦇𝒯⦈ ⟹ ⋃∘X ∈∘ 𝔖⦇𝒯⦈"
  using assms unfolding 𝒵_ts_def 𝒵_ts_axioms_def by auto

lemma 𝒵_tsE[elim]:
  assumes "𝒵_ts α 𝔖"
  obtains "𝒵_vfsequence α 𝔖"
    and "2ℕ ≤ vcard 𝔖"
    and "⋀A. A ∈∘ 𝔖⦇𝒯⦈ ⟹ A ⊆∘ 𝔖⦇𝒜⦈"
    and "𝔖⦇𝒜⦈ ∈∘ 𝔖⦇𝒯⦈"
    and "⋀A B. A ∈∘ 𝔖⦇𝒯⦈ ⟹ B ∈∘ 𝔖⦇𝒯⦈ ⟹ A ∩∘ B ∈∘ 𝔖⦇𝒯⦈"
    and "⋀X. X ⊆∘ 𝔖⦇𝒯⦈ ⟹ ⋃∘X ∈∘ 𝔖⦇𝒯⦈"
  using assms by auto


text‹Elementary properties.›

lemma (in 𝒵_ts) 𝒵_ts_vempty_in_ts: "0 ∈∘ 𝔖⦇𝒯⦈" 
  using 𝒵_ts_VUnion[of 0] by simp



subsection‹Indiscrete topology›

definition ts_indiscrete :: "V ⇒ V"
  where "ts_indiscrete A = [A, set {0, A}]∘"

named_theorems ts_indiscrete_simps

lemma ts_indiscrete_𝒜[ts_indiscrete_simps]: "ts_indiscrete A⦇𝒜⦈ = A"
  unfolding ts_indiscrete_def by (auto simp: ts_struct_field_simps)

lemma ts_indiscrete_𝒯[ts_indiscrete_simps]: "ts_indiscrete A⦇𝒯⦈ = set {0, A}"
  unfolding ts_indiscrete_def 
  by (simp add: ts_struct_field_simps nat_omega_simps)

lemma (in 𝒵) 𝒵_ts_ts_indiscrete:
  assumes "A ∈∘ Vset α"
  shows "𝒵_ts α (ts_indiscrete A)"
proof(intro 𝒵_tsI)

  show struct: "𝒵_vfsequence α (ts_indiscrete A)"
  proof(intro 𝒵_vfsequenceI)
    show "vfsequence (ts_indiscrete A)" unfolding ts_indiscrete_def by auto
    show "ℛ∘ (ts_indiscrete A) ⊆∘ Vset α"
    proof(intro vsubsetI)
      fix x assume "x ∈∘ ℛ∘ (ts_indiscrete A)" 
      then consider ‹x = A› | ‹x = set {0, A}›
        unfolding ts_indiscrete_def by auto
      then show "x ∈∘ Vset α" by cases (simp_all add: Axiom_of_Pairing assms)
    qed
  qed (simp_all add: 𝒵_axioms)
  
  interpret struct: 𝒵_vfsequence α ‹ts_indiscrete A› by (rule struct)

  show "X ⊆∘ ts_indiscrete A⦇𝒯⦈ ⟹ ⋃∘X ∈∘ ts_indiscrete A⦇𝒯⦈" for X
    unfolding ts_indiscrete_simps
  proof-
    assume "X ⊆∘ set {0, A}"
    then have "X ∈∘ VPow (set {0, A})" by force
    then consider ‹X = 0› | ‹X = set {0}› | ‹X = set {A}› | ‹X = set {0, A}›
      by auto
    then show "⋃∘X ∈∘ set {0, A}" by cases auto
  qed

  show "2ℕ ⊆∘ vcard (ts_indiscrete A)" unfolding ts_indiscrete_def by fastforce

qed (auto simp: ts_indiscrete_simps)

text‹\newpage›

end

Theory CZH_EX_Algebra

(* Copyright 2021 (C) Mihails Milehins *)

section‹Example III: abstract algebra›
theory CZH_EX_Algebra
  imports CZH_EX_TS
begin



subsection‹Background›


text‹
The section presents several examples of algebraic structures formalized
in ‹ZFC in HOL›. The definitions were adopted (with amendments) from the
main library of Isabelle/HOL.
›

named_theorems sgrp_struct_field_simps

lemmas [sgrp_struct_field_simps] = 𝒜_def



subsection‹Semigroup›


subsubsection‹Foundations›

definition mbinop where [sgrp_struct_field_simps]: "mbinop = 1ℕ"

locale 𝒵_sgrp_basis = 𝒵_vfsequence α 𝔖 + op: binop ‹𝔖⦇𝒜⦈› ‹𝔖⦇mbinop⦈› 
  for α 𝔖 +
  assumes 𝒵_sgrp_length: "vcard 𝔖 = 2ℕ"
    and 𝒵_sgrp_binop: "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"

abbreviation sgrp_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹⊙∘ı› 70)
  where "sgrp_app 𝔖 a b ≡ 𝔖⦇mbinop⦈⦇a, b⦈∙"
notation sgrp_app (infixl ‹⊙∘› 70)


text‹Rules.›

lemma 𝒵_sgrp_basisI[intro]:
  assumes "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 2ℕ"
    and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
  shows "𝒵_sgrp_basis α 𝔖"
  using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by simp

lemma 𝒵_sgrp_basisD[dest]:
  assumes "𝒵_sgrp_basis α 𝔖"
  shows "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 2ℕ"
    and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
  using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by auto

lemma 𝒵_sgrp_basisE[elim]:
  assumes "𝒵_sgrp_basis α 𝔖"
  shows "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 2ℕ"
    and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
  using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by auto


subsubsection‹Simple semigroup›

locale 𝒵_sgrp = 𝒵_sgrp_basis α 𝔖 for α 𝔖 +
  assumes 𝒵_sgrp_assoc: 
    "⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ 
      (a ⊙∘𝔖 b) ⊙∘𝔖 c = a ⊙∘𝔖 (b ⊙∘𝔖 c)"


text‹Rules.›

lemma 𝒵_sgrpI[intro]:
  assumes "𝒵_sgrp_basis α 𝔖" 
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ 
      (a ⊙∘𝔖 b) ⊙∘𝔖 c = a ⊙∘𝔖 (b ⊙∘𝔖 c)"
  shows "𝒵_sgrp α 𝔖"
  using assms unfolding 𝒵_sgrp_def 𝒵_sgrp_axioms_def by simp

lemma 𝒵_sgrpD[dest]:
  assumes "𝒵_sgrp α 𝔖"
  shows "𝒵_sgrp_basis α 𝔖" 
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ 
      (a ⊙∘𝔖 b) ⊙∘𝔖 c = a ⊙∘𝔖 (b ⊙∘𝔖 c)"
  using assms unfolding 𝒵_sgrp_def 𝒵_sgrp_axioms_def by simp_all

lemma 𝒵_sgrpE[elim]:
  assumes "𝒵_sgrp α 𝔖"
  obtains "𝒵_sgrp_basis α 𝔖" 
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ 
      (a ⊙∘𝔖 b) ⊙∘𝔖 c = a ⊙∘𝔖 (b ⊙∘𝔖 c)"
  using assms by auto



subsection‹Commutative semigroup›

locale 𝒵_csgrp = 𝒵_sgrp α 𝔖 for α 𝔖 +
  assumes 𝒵_csgrp_commutative: 
    "⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙∘𝔖 b = b ⊙∘𝔖 a"


text‹Rules.›

lemma 𝒵_csgrpI[intro]:
  assumes "𝒵_sgrp α 𝔖"
    and "⋀a b. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙∘𝔖 b = b ⊙∘𝔖 a"
  shows "𝒵_csgrp α 𝔖"
  using assms unfolding 𝒵_csgrp_def 𝒵_csgrp_axioms_def by simp

lemma 𝒵_csgrpD[dest]:
  assumes "𝒵_csgrp α 𝔖"
  shows "𝒵_sgrp α 𝔖"
    and "⋀a b. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙∘𝔖 b = b ⊙∘𝔖 a"
  using assms unfolding 𝒵_csgrp_def 𝒵_csgrp_axioms_def by simp_all

lemma 𝒵_csgrpE[elim]:
  assumes "𝒵_csgrp α 𝔖"
  obtains "𝒵_sgrp α 𝔖"
    and "⋀a b. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙∘𝔖 b = b ⊙∘𝔖 a"
  using assms by auto



subsection‹Semiring›


subsubsection‹Foundations›

definition vplus :: V where [sgrp_struct_field_simps]: "vplus = 1ℕ"
definition vmult :: V where [sgrp_struct_field_simps]: "vmult = 2ℕ"

abbreviation vplus_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹+∘ı› 65)
  where "a +∘𝔖 b ≡ 𝔖⦇vplus⦈⦇a,b⦈∙"
notation vplus_app (infixl ‹+∘ı› 65)

abbreviation vmult_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹*∘ı› 70)
  where "a *∘𝔖 b ≡ 𝔖⦇vmult⦈⦇a,b⦈∙"
notation vmult_app (infixl ‹*∘ı› 70)


subsubsection‹Simple semiring›

locale 𝒵_srng = 𝒵_vfsequence α 𝔖 for α 𝔖 +
  assumes 𝒵_srng_length: "vcard 𝔖 = 3ℕ"
    and 𝒵_srng_𝒵_csgrp_vplus: "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘"
    and 𝒵_srng_𝒵_sgrp_vmult: "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘"
    and 𝒵_srng_distrib_right: 
      "⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
        (a +∘𝔖 b) *∘𝔖 c = (a *∘𝔖 c) +∘𝔖 (b *∘𝔖 c)"
    and 𝒵_srng_distrib_left: 
      "⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
        a *∘𝔖 (b +∘𝔖 c) = (a *∘𝔖 b) +∘𝔖 (a *∘𝔖 c)"
begin

sublocale vplus: 𝒵_csgrp α ‹[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘›
  rewrites "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
    and "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘⦇mbinop⦈ = 𝔖⦇vplus⦈"
    and "sgrp_app [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘ = vplus_app 𝔖"
proof(rule 𝒵_srng_𝒵_csgrp_vplus)
  show "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
    and [simp]: "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘⦇mbinop⦈ = 𝔖⦇vplus⦈"
    by (auto simp: 𝒜_def mbinop_def nat_omega_simps)
  show "(⊙∘[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘) = (+∘𝔖)" by simp
qed

sublocale vmult: 𝒵_sgrp α ‹[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘›
  rewrites "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
    and "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘⦇mbinop⦈ = 𝔖⦇vmult⦈"
    and "sgrp_app [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘ = vmult_app 𝔖"
proof(rule 𝒵_srng_𝒵_sgrp_vmult)
  show "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
    and [simp]: "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘⦇mbinop⦈ = 𝔖⦇vmult⦈"
    by (auto simp: 𝒜_def mbinop_def nat_omega_simps)
  show "(⊙∘[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘) = (*∘𝔖)" by simp
qed

end


text‹Rules.›

lemma 𝒵_srngI[intro]:
  assumes "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 3ℕ"
    and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘"
    and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      (a +∘𝔖 b) *∘𝔖 c = (a *∘𝔖 c) +∘𝔖 (b *∘𝔖 c)"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      a *∘𝔖 (b +∘𝔖 c) = (a *∘𝔖 b) +∘𝔖 (a *∘𝔖 c)"
  shows "𝒵_srng α 𝔖"
  using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by simp

lemma 𝒵_srngD[dest]:
  assumes "𝒵_srng α 𝔖"
  shows "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 3ℕ"
    and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘"
    and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      (a +∘𝔖 b) *∘𝔖 c = (a *∘𝔖 c) +∘𝔖 (b *∘𝔖 c)"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      a *∘𝔖 (b +∘𝔖 c) = (a *∘𝔖 b) +∘𝔖 (a *∘𝔖 c)"
  using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by simp_all

lemma 𝒵_srngE[elim]:
  assumes "𝒵_srng α 𝔖"
  obtains "𝒵_vfsequence α 𝔖"
    and "vcard 𝔖 = 3ℕ"
    and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]∘"
    and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]∘"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      (a +∘𝔖 b) *∘𝔖 c = (a *∘𝔖 c) +∘𝔖 (b *∘𝔖 c)"
    and "⋀a b c. ⟦ a ∈∘ 𝔖⦇𝒜⦈; b ∈∘ 𝔖⦇𝒜⦈; c ∈∘ 𝔖⦇𝒜⦈ ⟧ ⟹
      a *∘𝔖 (b +∘𝔖 c) = (a *∘𝔖 b) +∘𝔖 (a *∘𝔖 c)"
  using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by auto



subsection‹Integer numbers form a semiring›

definition vint_struct :: V (‹𝔖ℤ›)
  where "vint_struct = [ℤ∘, vint_plus, vint_mult]∘"

named_theorems vint_struct_simps

lemma vint_struct_𝒜[vint_struct_simps]: "𝔖ℤ⦇𝒜⦈ = ℤ∘"
  unfolding vint_struct_def by (auto simp: sgrp_struct_field_simps)

lemma vint_struct_vplus[vint_struct_simps]: "𝔖ℤ⦇vplus⦈ = vint_plus"
  unfolding vint_struct_def 
  by (simp add: sgrp_struct_field_simps nat_omega_simps)

lemma vint_struct_vmult[vint_struct_simps]: "𝔖ℤ⦇vmult⦈ = vint_mult"
  unfolding vint_struct_def 
  by (simp add: sgrp_struct_field_simps nat_omega_simps)

context 𝒵
begin

lemma 𝒵_srng_vint: "𝒵_srng α 𝔖ℤ"
proof(intro 𝒵_srngI, unfold vint_struct_simps)

  interpret 𝔖: vfsequence ‹𝔖ℤ› unfolding vint_struct_def by simp

  show vint_struct: "𝒵_vfsequence α 𝔖ℤ"
  proof(intro 𝒵_vfsequenceI)
    show "vfsequence 𝔖ℤ" unfolding vint_struct_def by simp
    show "ℛ∘ 𝔖ℤ ⊆∘ Vset α"
    proof(intro vsubsetI)
      fix x assume "x ∈∘ ℛ∘ 𝔖ℤ"
      then consider ‹x = ℤ∘› | ‹x = vint_plus› | ‹x = vint_mult› 
        unfolding vint_struct_def by fastforce
      then show "x ∈∘ Vset α"
      proof cases
        case 1 with 𝒵_Vset_ω2_vsubset_Vset vint_in_Vset_ω2 show ?thesis by auto
      next
        case 2
        have "𝒟∘ vint_plus ∈∘ Vset α"
          unfolding vint_plus.nop_vdomain
        proof(rule Limit_vcpower_in_VsetI)
          from Axiom_of_Infinity show "2ℕ ∈∘ Vset α" by auto
          from 𝒵_Vset_ω2_vsubset_Vset show "ℤ∘ ∈∘ Vset α" 
            by (auto intro: vint_in_Vset_ω2)
        qed auto
        moreover from 𝒵_Vset_ω2_vsubset_Vset have "ℛ∘ vint_plus ∈∘ Vset α"
          unfolding vint_plus.nop_onto_vrange by (auto intro: vint_in_Vset_ω2)
        ultimately show "x ∈∘ Vset α"
          unfolding 2
          by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_plus_def)
      next
        case 3
        have "𝒟∘ vint_mult ∈∘ Vset α"
          unfolding vint_mult.nop_vdomain
        proof(rule Limit_vcpower_in_VsetI)
          from Axiom_of_Infinity show "2ℕ ∈∘ Vset α" by auto
          from 𝒵_Vset_ω2_vsubset_Vset show "ℤ∘ ∈∘ Vset α" 
            by (auto intro: vint_in_Vset_ω2)
        qed auto
        moreover from 𝒵_Vset_ω2_vsubset_Vset Axiom_of_Infinity have 
          "ℛ∘ vint_mult ∈∘ Vset α"
          unfolding vint_mult.nop_onto_vrange by (auto intro: vint_in_Vset_ω2)
        ultimately show "x ∈∘ Vset α"
          unfolding 3
          by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_mult_def)
      qed
    qed
  qed (simp add: 𝒵_axioms)

  interpret vint_struct: 𝒵_vfsequence α ‹𝔖ℤ› by (rule vint_struct)
  
  show "vcard 𝔖ℤ = 3ℕ" 
    unfolding vint_struct_def by (simp add: nat_omega_simps)

  have [vint_struct_simps]:
    "[ℤ∘, vint_plus]∘⦇𝒜⦈ = ℤ∘" "[ℤ∘, vint_plus]∘⦇mbinop⦈ = vint_plus"
    "[ℤ∘, vint_mult]∘⦇𝒜⦈ = ℤ∘" "[ℤ∘, vint_mult]∘⦇mbinop⦈ = vint_mult"
    by (auto simp: sgrp_struct_field_simps nat_omega_simps)

  have [vint_struct_simps]:
    "sgrp_app [ℤ∘, vint_plus]∘ = (+ℤ)"
    "sgrp_app [ℤ∘, vint_mult]∘ = (*ℤ)"
    unfolding vint_struct_simps by simp_all

  show "𝒵_csgrp α [ℤ∘, vint_plus]∘"
  proof(intro 𝒵_csgrpI, unfold vint_struct_simps)
    show "𝒵_sgrp α [ℤ∘, vint_plus]∘"
    proof(intro 𝒵_sgrpI 𝒵_sgrp_basisI, unfold vint_struct_simps)
      show "𝒵_vfsequence α [ℤ∘, vint_plus]∘"
      proof(intro 𝒵_vfsequenceI)
        show "ℛ∘ [ℤ∘, vint_plus]∘ ⊆∘ Vset α"
        proof(intro vfsequence_vrange_vconsI)
          from 𝒵_Vset_ω2_vsubset_Vset show [simp]: "ℤ∘ ∈∘ Vset α"
            by (auto intro: vint_in_Vset_ω2)
          show "vint_plus ∈∘ Vset α"
          proof(rule vbrelation.vbrelation_Limit_in_VsetI)
            from Axiom_of_Infinity show "𝒟∘ vint_plus ∈∘ Vset α"
              unfolding vint_plus.nop_vdomain 
              by (intro Limit_vcpower_in_VsetI) auto
            from Axiom_of_Infinity show "ℛ∘ vint_plus ∈∘ Vset α" 
              unfolding vint_plus.nop_onto_vrange by auto
          qed (simp_all add: vint_plus_def)
        qed simp_all
      qed (simp_all add: 𝒵_axioms)
    qed 
      (
         auto simp:
          nat_omega_simps
          vint_plus.binop_axioms
          vint_assoc_law_addition
      ) 
  qed (simp add: vint_commutative_law_addition)

  show "𝒵_sgrp α [ℤ∘, vint_mult]∘"
  proof
    (
      intro 𝒵_sgrpI 𝒵_sgrp_basisI; 
      (unfold vint_struct_simps | tactic‹all_tac›)
    )
    show "𝒵_vfsequence α [ℤ∘, vint_mult]∘"
    proof(intro 𝒵_vfsequenceI; (unfold vint_struct_simps | tactic‹all_tac›))
      from 𝒵_axioms show "𝒵 α" by simp
      show "ℛ∘ [ℤ∘, vint_mult]∘ ⊆∘ Vset α"
      proof(intro vfsequence_vrange_vconsI)
        from 𝒵_Vset_ω2_vsubset_Vset show [simp]: "ℤ∘ ∈∘ Vset α"
          by (auto intro: vint_in_Vset_ω2)
        show "vint_mult ∈∘ Vset α"
        proof(rule vbrelation.vbrelation_Limit_in_VsetI)
          from Axiom_of_Infinity show "𝒟∘ vint_mult ∈∘ Vset α"
            unfolding vint_mult.nop_vdomain 
            by (intro Limit_vcpower_in_VsetI) auto
          from Axiom_of_Infinity show "ℛ∘ vint_mult ∈∘ Vset α" 
            unfolding vint_mult.nop_onto_vrange by auto
        qed (simp_all add: vint_mult_def)
      qed simp_all
    qed auto
  qed
    (
      auto simp: 
        nat_omega_simps
        vint_mult.binop_axioms
        vint_assoc_law_multiplication
    )

qed
  (
    auto simp: 
      vint_commutative_law_multiplication 
      vint_plus_closed 
      vint_distributive_law
  )


text‹Interpretation.›

interpretation vint: 𝒵_srng α ‹𝔖ℤ›
  rewrites "𝔖ℤ⦇𝒜⦈ = ℤ∘"
    and "𝔖ℤ⦇vplus⦈ = vint_plus"
    and "𝔖ℤ⦇vmult⦈ = vint_mult"
    and "vplus_app (𝔖ℤ) = vint_plus_app"
    and "vmult_app (𝔖ℤ) = vint_mult_app"
  unfolding vint_struct_simps by (rule 𝒵_srng_vint) simp_all

thm vint.vmult.𝒵_sgrp_assoc
thm vint.vplus.𝒵_sgrp_assoc
thm vint.𝒵_srng_distrib_left

end

text‹\newpage›

end

Theory CZH_Sets_Conclusions

(* Copyright 2021 (C) Mihails Milehins *)

theory CZH_Sets_Conclusions
  imports 
    CZH_Sets_Introduction
    CZH_Sets_Sets
    CZH_Sets_Nat
    CZH_Sets_BRelations
    CZH_Sets_IF
    CZH_Sets_Equipollence
    CZH_Sets_Cardinality
    CZH_Sets_Ordinals
    CZH_Sets_VNHS
    CZH_Sets_FSequences
    CZH_Sets_FBRelations
    CZH_Sets_NOP
    CZH_Sets_ZQR
    CZH_EX_Replacement
    CZH_EX_TS
    CZH_EX_Algebra    
begin
end

Theory CZH_DG_Introduction

(* Copyright 2021 (C) Mihails Milehins *)

chapter‹Digraphs›

section‹Introduction›
theory CZH_DG_Introduction
  imports
    "HOL-Library.Rewrite"
    CZH_Sets_NOP
    CZH_Sets_VNHS
begin



subsection‹Background›


text‹
Many concepts that are normally associated with category theory can be
generalized to directed graphs. It is the goal of
this chapter to expose these generalized concepts and provide the
relevant foundations for the development of the notion of a semicategory
in the next chapter.
It is important to note, however, that it is not the goal of this chapter 
to present a comprehensive canonical theory of directed graphs. 
Nonetheless, there is little that could prevent one from extending this 
body of work by providing canonical results from the theory of directed 
graphs.
›



subsection‹Preliminaries›

declare One_nat_def[simp del]

named_theorems slicing_simps
named_theorems slicing_commute
named_theorems slicing_intros

named_theorems dg_op_simps
named_theorems dg_op_intros

named_theorems dg_cs_simps
named_theorems dg_cs_intros

named_theorems dg_shared_cs_simps
named_theorems dg_shared_cs_intros



subsection‹CS setup for foundations›

named_theorems V_cs_simps
named_theorems V_cs_intros

named_theorems Ord_cs_simps
named_theorems Ord_cs_intros


subsubsection‹‹HOL››

lemma (in semilattice_sup) sup_commute':
  shows "b' = b ⟹ a' = a ⟹ a ⊔ b = b' ⊔ a'"
    and "b' = b ⟹ a' = a ⟹ a ⊔ b' = b ⊔ a'"
    and "b' = b ⟹ a' = a ⟹ a' ⊔ b = b' ⊔ a"
    and "b' = b ⟹ a' = a ⟹ a ⊔ b' = b ⊔ a'"
    and "b' = b ⟹ a' = a ⟹ a' ⊔ b' = b ⊔ a"
  by (auto simp: sup.commute)

lemma (in semilattice_inf) inf_commute':
  shows "b' = b ⟹ a' = a ⟹ a ⊓ b = b' ⊓ a'"
    and "b' = b ⟹ a' = a ⟹ a ⊓ b' = b ⊓ a'"
    and "b' = b ⟹ a' = a ⟹ a' ⊓ b = b' ⊓ a"
    and "b' = b ⟹ a' = a ⟹ a ⊓ b' = b ⊓ a'"
    and "b' = b ⟹ a' = a ⟹ a' ⊓ b' = b ⊓ a"
  by (auto simp: inf.commute)

lemmas [V_cs_simps] =
  if_P 
  if_not_P
  inf.absorb1
  inf.absorb2
  sup.absorb1
  sup.absorb2
  add_0_right 
  add_0

lemmas [V_cs_intros] = 
  sup_commute' 
  inf_commute' 
  sup.commute
  inf.commute


subsubsection‹Foundations›

abbreviation (input) if3 :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "if3 a b c ≡
    (
      λi. if i = 0 ⇒ a
           | i = 1ℕ ⇒ b
           | otherwise ⇒ c
    )"
lemma if3_0[V_cs_simps]: "if3 a b c 0 = a" by auto
lemma if3_1[V_cs_simps]: "if3 a b c (1ℕ) = b" by auto
lemma if3_2[V_cs_simps]: "if3 a b c (2ℕ) = c" by auto

lemma vinsertI1':
  assumes "x' = x"
  shows "x ∈∘ vinsert x' A"
  unfolding assms by (rule vinsertI1)

lemma in_vsingleton[V_cs_intros]:
  assumes "f = a"
  shows "f ∈∘ set {a}"
  unfolding assms by simp

lemma a_in_succ_a: "a ∈∘ succ a" by simp

lemma a_in_succ_xI:
  assumes "a ∈∘ x"
  shows "a ∈∘ succ x"
  using assms by simp

lemma vone_ne[V_cs_intros]: "1ℕ ≠ 0" by clarsimp

lemmas [V_cs_simps] =
  vinsert_set_insert_eq
  beta 
  set_empty
  vcard_0
   
lemmas [V_cs_intros] = 
  mem_not_refl 
  succ_notin_self
  vset_neq_1  
  vset_neq_2 
  nin_vinsertI
  vinsertI1'
  vinsertI2
  vfinite_vinsert
  vfinite_vsingleton
  vdisjnt_nin_right
  vdisjnt_nin_left
  vunionI1 
  vunionI2
  vunion_in_VsetI
  vintersection_in_VsetI
  vsubset_reflexive
  vsingletonI
  small_insert small_empty
  Limit_vtimes_in_VsetI 
  Limit_VPow_in_VsetI
  a_in_succ_a
  vsubset_vempty


subsubsection‹Binary relations›

lemma vtimesI'[V_cs_intros]:
  assumes "ab = ⟨a, b⟩" and "a ∈∘ A" and "b ∈∘ B" 
  shows "ab ∈∘ A ×∘ B"
  using assms by simp

lemma vrange_vcomp_vsubset[V_cs_intros]:
  assumes "ℛ∘ r ⊆∘ B"
  shows "ℛ∘ (r ∘∘ s) ⊆∘ B"
  using assms by auto

lemma vrange_vconst_on_vsubset[V_cs_intros]:
  assumes "a ∈∘ R"
  shows "ℛ∘ (vconst_on A a) ⊆∘ R"
  using assms by auto

lemma vrange_vcomp_eq_vrange[V_cs_simps]:
  assumes "𝒟∘ r = ℛ∘ s"
  shows "ℛ∘ (r ∘∘ s) = ℛ∘ r"
  using assms by (metis vimage_vdomain vrange_vcomp)

lemmas [V_cs_simps] =
  vdomain_vsingleton
  vdomain_vlrestriction
  vdomain_vcomp_vsubset
  vdomain_vconverse
  vrange_vconverse
  vdomain_vconst_on
  vconverse_vtimes
  vdomain_VLambda


subsubsection‹Single-valued functions›

lemmas (in vsv) [V_cs_intros] = vsv_axioms

lemma vpair_app:
  assumes "j = a"
  shows "set {⟨a, b⟩}⦇j⦈ = b"
  unfolding assms by simp

lemmas [V_cs_simps] =
  vpair_app
  vsv.vlrestriction_app
  vsv_vcomp_at

lemmas (in vsv) [V_cs_intros] = vsv_vimageI2'

lemmas [V_cs_intros] =
  vsv_vsingleton
  vsv.vsv_vimageI2'
  vsv_vcomp


subsubsection‹Injective single-valued functions›

lemmas (in v11) [V_cs_intros] = v11_axioms

lemma (in v11) v11_vconverse_app_in_vdomain':
  assumes "y ∈∘ ℛ∘ r" and "A = 𝒟∘ r"
  shows "r¯∘⦇y⦈ ∈∘ A"
  using assms(1) unfolding assms(2) by (rule v11_vconverse_app_in_vdomain)

lemmas (in v11) [V_cs_intros] = v11_vconverse_app_in_vdomain'
lemmas [V_cs_intros] = v11.v11_vconverse_app_in_vdomain'

lemmas (in v11) [V_cs_simps] = (*only in the context of v11*)
  v11_app_if_vconverse_app[rotated -2]
  v11_app_vconverse_app 
  v11_vconverse_app_app

lemmas [V_cs_simps] = 
  v11.v11_vconverse_app[rotated -1]
  v11.v11_app_vconverse_app 
  v11.v11_vconverse_app_app

lemmas [V_cs_intros] =
  v11D(1)
  v11.v11_vconverse
  v11_vcomp


subsubsection‹Operations on indexed families of sets›

lemmas [V_cs_simps] = 
  vprojection_app 
  vprojection_vdomain

lemmas [V_cs_intros] = vprojection_vsv


subsubsection‹Finite sequences›

lemmas (in vfsequence) [V_cs_intros] = vfsequence_axioms

lemmas (in vfsequence) [V_cs_simps] = vfsequence_vdomain
lemmas [V_cs_simps] = vfsequence.vfsequence_vdomain

lemmas [V_cs_intros] = 
  vfsequence.vfsequence_vcons
  vfsequence_vempty

lemmas [V_cs_simps] = 
  vfinite_0_left 
  vfinite_0_right


subsubsection‹Binary relation as a finite sequence›

lemmas [V_cs_simps] = 
  fconverse_vunion
  fconverse_ftimes
  vdomain_fflip


subsubsection‹Ordinals›

lemmas [Ord_cs_intros] = 
  Limit_right_Limit_mult
  Limit_left_Limit_mult
  Ord_succ_mono
  Limit_plus_omega_vsubset_Limit
  Limit_plus_nat_in_Limit
 

subsubsection‹von Neumann hierarchy›

lemma (in 𝒵) omega_in_any[V_cs_intros]:
  assumes "α ⊆∘ β"
  shows "ω ∈∘ β" 
  using assms by auto

lemma Ord_vsubset_succ[V_cs_intros]:
  assumes "Ord α" and "Ord β" and "α ⊆∘ β"
  shows "α ⊆∘ succ β" 
  by (metis Ord_linear_le Ord_succ assms(1) assms(2) assms(3) leD succ_le_iff)

lemma Ord_in_Vset_succ[V_cs_intros]:
  assumes "Ord α" and "a ∈∘ Vset α"
  shows "a ∈∘ Vset (succ α)"
  using assms by (auto simp: Ord_Vset_in_Vset_succI)

lemma Ord_vsubset_Vset_succ[V_cs_intros]:
  assumes "Ord α" and "B ⊆∘ Vset α"
  shows "B ⊆∘ Vset (succ α)"
  by (intro vsubsetI) 
    (auto simp: assms Vset_trans Ord_vsubset_in_Vset_succI)

lemmas (in 𝒵) [V_cs_intros] = 
  omega_in_α
  Ord_α
  Limit_α

lemmas [V_cs_intros] =
  vempty_in_Vset_succ
  𝒵.ord_of_nat_in_Vset
  Vset_in_mono
  Limit_vpair_in_VsetI
  Vset_vsubset_mono 
  Ord_succ
  Limit_vempty_in_VsetI
  Limit_insert_in_VsetI
  vfsequence.vfsequence_Limit_vcons_in_VsetI
  vfsequence.vfsequence_Ord_vcons_in_Vset_succI
  Limit_vdoubleton_in_VsetI
  Limit_omega_in_VsetI
  Limit_ftimes_in_VsetI


subsubsection‹‹n›-ary operations›

lemmas [V_cs_simps] =
  fflip_app
  vdomain_fflip


subsubsection‹Countable ordinals as a set›

named_theorems omega_of_set
named_theorems nat_omega_simps_extra

lemmas [nat_omega_simps_extra] = 
  add_num_simps 
  Suc_numeral 
  Suc_1 
  le_num_simps
  less_numeral_simps(1,2)
  less_num_simps 
  less_one
  nat_omega_simps

lemmas [omega_of_set] = nat_omega_simps_extra

lemma set_insert_succ[omega_of_set]:
  assumes [simp]: "small b" and "set b = aℕ"
  shows "set (insert (aℕ) b) = succ (aℕ)"
  unfolding assms(2)[symmetric] by auto

lemma set_0[omega_of_set]: "set {0} = succ 0" by auto


subsubsection‹Sequences›

named_theorems vfsequence_simps
named_theorems vfsequence_intros

lemmas [vfsequence_simps] =
  vfsequence.vfsequence_at_last[rotated]
  vfsequence.vfsequence_vcard_vcons[rotated]
  vfsequence.vfsequence_at_not_last[rotated]

lemmas [vfsequence_intros] = 
  vfsequence.vfsequence_vcons
  vfsequence_vempty


subsubsection‹Further numerals›

named_theorems nat_omega_intros

lemma [nat_omega_intros]:
  assumes "a < b"
  shows "aℕ ∈∘ bℕ"
  using assms by simp

lemma [nat_omega_intros]: 
  assumes "0 < b"
  shows "0 ∈∘ bℕ" 
  using assms by auto

lemma [nat_omega_intros]:
  assumes "a = numeral b"
  shows "(0::nat) < a"
  using assms by auto

lemma nat_le_if_in[nat_omega_intros]:
  assumes "xℕ ∈∘ yℕ"
  shows "xℕ ≤ yℕ"
  using assms by auto

lemma vempty_le_nat[nat_omega_intros]: "0 ≤ yℕ" by auto

lemmas [nat_omega_intros] = 
  preorder_class.order_refl
  preorder_class.eq_refl


subsubsection‹Generally available foundational results›

lemma (in 𝒵) 𝒵_β:
  assumes "β = α"
  shows "𝒵 β"
  unfolding assms by auto

lemmas (in 𝒵) [dg_cs_intros] = 𝒵_β 

text‹\newpage›

end

Theory CZH_DG_Digraph

(* Copyright 2021 (C) Mihails Milehins *)

section‹Digraph\label{sec:digraph}›
theory CZH_DG_Digraph
  imports CZH_DG_Introduction
begin



subsection‹Background›

named_theorems dg_field_simps

definition Obj :: V where [dg_field_simps]: "Obj = 0"
definition Arr :: V where [dg_field_simps]: "Arr = 1ℕ"
definition Dom :: V where [dg_field_simps]: "Dom = 2ℕ"
definition Cod :: V where [dg_field_simps]: "Cod = 3ℕ"



subsection‹Arrow with a domain and a codomain›


text‹
The definition of and notation for an arrow with a domain and codomain is
adapted from Chapter I-1 in \cite{mac_lane_categories_2010}.
The definition is applicable to digraphs and all other relevant derived
entities, such as semicategories and categories, that are presented in
the subsequent chapters.

In this work, by convention, the definition of an arrow with a domain and a 
codomain is nearly always preferred to the explicit use of the domain 
and codomain functions for the specification of the fundamental properties 
of arrows.
Thus, to say that ‹f› is an arrow with the domain ‹a›, it is preferable
to write ‹f : a ↦ℭ b› (‹b› can be assumed to be arbitrary) instead
of term‹f ∈∘ ℭ⦇Arr⦈› and term‹ℭ⦇Dom⦈⦇f⦈ = a›.
›

definition is_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_arr ℭ a b f ⟷ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇f⦈ = a ∧ ℭ⦇Cod⦈⦇f⦈ = b"

syntax "_is_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" (‹_ : _ ↦ı _› [51, 51, 51] 51)
translations "f : a ↦ℭ b" ⇌ "CONST is_arr ℭ a b f"


text‹Rules.›

mk_ide is_arr_def
  |intro is_arrI|
  |dest is_arrD[dest]|
  |elim is_arrE[elim]|

lemmas [dg_shared_cs_intros, dg_cs_intros] = is_arrD(1)
lemmas [dg_shared_cs_simps, dg_cs_simps] = is_arrD(2,3)



subsection‹‹Hom›-set›


text‹See Chapter I-8 in \cite{mac_lane_categories_2010}.›

abbreviation Hom :: "V ⇒ V ⇒ V ⇒ V" 
  where "Hom ℭ a b ≡ set {f. f : a ↦ℭ b}"

lemma small_Hom[simp]: "small {f. f : a ↦ℭ b}" unfolding is_arr_def by simp


text‹Rules.›

lemma HomI[dg_shared_cs_intros, dg_cs_intros]:
  assumes "f : a ↦ℭ b"
  shows "f ∈∘ Hom ℭ a b"
  using assms by auto

lemma in_Hom_iff[dg_shared_cs_simps, dg_cs_simps]: 
  "f ∈∘ Hom ℭ a b ⟷ f : a ↦ℭ b" 
  by simp


text‹
The ‹Hom›-sets in a given digraph are pairwise disjoint. This property 
was exposed as Axiom (v) in an alternative definition of a category presented 
in Chapter I-8 in \cite{mac_lane_categories_2010}. Within the scope of the 
definitional framework employed in this study, this property holds 
unconditionally.
›

lemma Hom_vdisjnt: 
  assumes "a ≠ a' ∨ b ≠ b'" 
    and "a ∈∘ ℭ⦇Obj⦈"
    and "a' ∈∘ ℭ⦇Obj⦈"
    and "b ∈∘ ℭ⦇Obj⦈" 
    and "b' ∈∘ ℭ⦇Obj⦈"
  shows "vdisjnt (Hom ℭ a b) (Hom ℭ a' b')"
proof(intro vdisjntI, unfold in_Hom_iff)
  fix g f assume "g : a ↦ℭ b" and "f : a' ↦ℭ b'" 
  then have "g ∈∘ ℭ⦇Arr⦈"
    and "f ∈∘ ℭ⦇Arr⦈"
    and "ℭ⦇Dom⦈⦇g⦈ = a"
    and "ℭ⦇Cod⦈⦇g⦈ = b"
    and "ℭ⦇Dom⦈⦇f⦈ = a'"
    and "ℭ⦇Cod⦈⦇f⦈ = b'"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
  with assms(1) have "ℭ⦇Dom⦈⦇g⦈ ≠ ℭ⦇Dom⦈⦇f⦈ ∨ ℭ⦇Cod⦈⦇g⦈ ≠ ℭ⦇Cod⦈⦇f⦈" by auto
  then show "g ≠ f" by clarsimp
qed



subsection‹Digraph: background information›


text‹
The definition of a digraph that is employed in this work is similar
to the definition of a ‹directed graph› presented in Chapter I-2 in 
\cite{mac_lane_categories_2010}. However, there are notable differences.
More specifically, the definition is parameterized by a limit ordinal ‹α›, 
such that ‹ω < α›; the set of objects is assumed to be a subset 
of the set ‹Vα› in the von Neumann hierarchy of sets (e.g., 
see \cite{takeuti_introduction_1971}). Such digraphs are called ‹α›-‹digraphs› 
to make the dependence on the parameter ‹α› explicit.\footnote{
The prefix ``‹α›-'' may be omitted whenever it is possible to infer the value 
of ‹α› from the context. This applies not only to the digraphs, but all 
other entities that are parameterized by a limit ordinal ‹α› such that 
‹ω < α›.} This definition was inspired by the ideas expressed in 
\cite{feferman_set-theoretical_1969}, \cite{sica_doing_2006} and
\cite{shulman_set_2008}.

In ZFC in HOL, the predicate term‹small› is used for distinguishing the
terms of any type of the form typ‹'a set› that are isomorphic to elements 
of a term of the type typ‹V› (the elements can be exposed via the predicate
const‹elts›). Thus, the collection of the elements associated with any term of 
the type typ‹V› (e.g., term‹elts (a::V)›) is always small 
(see the theorem @{thm [source] small_elts} in \cite{paulson_zermelo_2019}).
Therefore, in this study, in an attempt to avoid confusion, the term ``small''
is never used to refer to digraphs. 
Instead, a new terminology is introduced in this body of work.

Thus, in this work, an ‹α›-digraph is a tiny ‹α›-digraph if and only if 
the set of its objects and the set of its arrows both belong to the set ‹Vα›. 
This notion is similar to the notion of a small category in the sense of 
the definition employed in Chapter I-6 in \cite{mac_lane_categories_2010}, 
if it is assumed that the ``smallness'' is determined with respect to the 
set ‹Vα› instead of the universe ‹U›. Also, in what follows, any member of 
the set ‹Vα› will be referred to as an ‹α›-tiny set.

All of the large (i.e. non-tiny) digraphs 
that are considered within the scope of this work have a slightly 
unconventional condition associated with the size of their ‹Hom›-sets. 
This condition implies that all ‹Hom›-sets of a digraph 
are tiny, but it is not equivalent to 
all ‹Hom›-sets being tiny. The condition was introduced in an attempt to
resolve some of the issues related to the lack of an analogue of the 
Axiom Schema of Replacement closed with respect to ‹Vα›. 
›



subsection‹Digraph: definition and elementary properties›

locale digraph = 𝒵 α + vfsequence ℭ + Dom: vsv ‹ℭ⦇Dom⦈› + Cod: vsv ‹ℭ⦇Cod⦈› 
  for α ℭ +
  assumes dg_length[dg_cs_simps]: "vcard ℭ = 4ℕ"  
    and dg_Dom_vdomain[dg_cs_simps]: "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"    
    and dg_Dom_vrange: "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and dg_Cod_vdomain[dg_cs_simps]: "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and dg_Cod_vrange: "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and dg_Obj_vsubset_Vset: "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and dg_Hom_vifunion_in_Vset[dg_cs_intros]: 
      "⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹ 
        (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"

lemmas [dg_cs_simps] = 
  digraph.dg_length
  digraph.dg_Dom_vdomain
  digraph.dg_Cod_vdomain

lemmas [dg_cs_intros] = 
  digraph.dg_Hom_vifunion_in_Vset


text‹Rules.›

lemma (in digraph) digraph_axioms'[dg_cs_intros]:
  assumes "α' = α"
  shows "digraph α' ℭ"
  unfolding assms by (rule digraph_axioms)

mk_ide rf digraph_def[unfolded digraph_axioms_def]
  |intro digraphI|
  |dest digraphD[dest]|
  |elim digraphE[elim]|


text‹Elementary properties.›

lemma dg_eqI:
  assumes "digraph α 𝔄" 
    and "digraph α 𝔅"
    and "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
    and "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
    and "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
    and "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄: digraph α 𝔄 by (rule assms(1))
  interpret 𝔅: digraph α 𝔅 by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom_lhs: "𝒟∘ 𝔄 = 4ℕ" by (cs_concl cs_simp: V_cs_simps dg_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔄 ⟹ 𝔄⦇a⦈ = 𝔅⦇a⦈" for a 
      by (unfold dom_lhs, elim_in_numeral, insert assms)
        (auto simp: dg_field_simps)
  qed (cs_concl cs_simp: V_cs_simps dg_cs_simps cs_intro: V_cs_intros)+
qed

lemma (in digraph) dg_def: "ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ ℭ = 4ℕ" by (cs_concl cs_simp: V_cs_simps dg_cs_simps)
  have dom_rhs: "𝒟∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]∘ = 4ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ ℭ = 𝒟∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]∘"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ ℭ ⟹ ℭ⦇a⦈ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]∘⦇a⦈" for a
    by (unfold dom_lhs, elim_in_numeral, unfold dg_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in digraph) dg_Obj_if_Dom_vrange:
  assumes "a ∈∘ ℛ∘ (ℭ⦇Dom⦈)"
  shows "a ∈∘ ℭ⦇Obj⦈"
  using assms dg_Dom_vrange by auto

lemma (in digraph) dg_Obj_if_Cod_vrange:
  assumes "a ∈∘ ℛ∘ (ℭ⦇Cod⦈)"
  shows "a ∈∘ ℭ⦇Obj⦈"
  using assms dg_Cod_vrange by auto

lemma (in digraph) dg_is_arrD:
  assumes "f : a ↦ℭ b" 
  shows "f ∈∘ ℭ⦇Arr⦈" 
    and "a ∈∘ ℭ⦇Obj⦈"
    and "b ∈∘ ℭ⦇Obj⦈"
    and "ℭ⦇Dom⦈⦇f⦈ = a" 
    and "ℭ⦇Cod⦈⦇f⦈ = b"
proof-
  from assms show prems: "f ∈∘ ℭ⦇Arr⦈" 
    and fa[symmetric]: "ℭ⦇Dom⦈⦇f⦈ = a"
    and fb[symmetric]: "ℭ⦇Cod⦈⦇f⦈ = b"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
  from digraph_axioms prems have "f ∈∘ 𝒟∘ (ℭ⦇Dom⦈)" "f ∈∘ 𝒟∘ (ℭ⦇Cod⦈)"
    by (cs_concl cs_simp: dg_cs_simps)+
  with assms show "a ∈∘ ℭ⦇Obj⦈" "b ∈∘ ℭ⦇Obj⦈"  
    by 
      (
        cs_concl 
          cs_intro: dg_Obj_if_Dom_vrange dg_Obj_if_Cod_vrange V_cs_intros
          cs_simp: fa fb
      )+
qed

lemmas [dg_cs_intros] = digraph.dg_is_arrD(1-3)

lemma (in digraph) dg_is_arrE[elim]:
  assumes "f : a ↦ℭ b" 
  obtains "f ∈∘ ℭ⦇Arr⦈" 
    and "a ∈∘ ℭ⦇Obj⦈"
    and "b ∈∘ ℭ⦇Obj⦈"
    and "ℭ⦇Dom⦈⦇f⦈ = a" 
    and "ℭ⦇Cod⦈⦇f⦈ = b"
  using assms by (blast dest: dg_is_arrD)

lemma (in digraph) dg_in_ArrE[elim]:
  assumes "f ∈∘ ℭ⦇Arr⦈"
  obtains a b where "f : a ↦ℭ b" and "a ∈∘ ℭ⦇Obj⦈" and "b ∈∘ ℭ⦇Obj⦈"
  using assms by (auto dest: dg_is_arrD(2,3) is_arrI)

lemma (in digraph) dg_Hom_in_Vset[dg_cs_intros]: 
  assumes "a ∈∘ ℭ⦇Obj⦈" and "b ∈∘ ℭ⦇Obj⦈"
  shows "Hom ℭ a b ∈∘ Vset α"
proof-
  let ?A = ‹set {a}› and ?B = ‹set {b}›
  from assms have A: "?A ⊆∘ ℭ⦇Obj⦈" and B: "?B ⊆∘ ℭ⦇Obj⦈" by auto
  from assms dg_Obj_vsubset_Vset have "a ∈∘ Vset α" and "b ∈∘ Vset α" by auto
  then have a: "set {a} ∈∘ Vset α" and b: "set {b} ∈∘ Vset α" 
    by (metis Axiom_of_Pairing insert_absorb2)+
  from dg_Hom_vifunion_in_Vset[OF A B a b] show "Hom ℭ a b ∈∘ Vset α" by simp
qed

lemmas [dg_cs_intros] = digraph.dg_Hom_in_Vset


text‹Size.›

lemma (in digraph) dg_Arr_vsubset_Vset: "ℭ⦇Arr⦈ ⊆∘ Vset α"
proof(intro vsubsetI)
  fix f assume "f ∈∘ ℭ⦇Arr⦈"
  then obtain a b 
    where f: "f : a ↦ℭ b" and a: "a ∈∘ ℭ⦇Obj⦈" and b: "b ∈∘ ℭ⦇Obj⦈"
    by blast
  show "f ∈∘ Vset α"
    by (rule Vset_trans, rule HomI[OF f], rule dg_Hom_in_Vset[OF a b])
qed

lemma (in digraph) dg_Dom_vsubset_Vset: "ℭ⦇Dom⦈ ⊆∘ Vset α"
  by 
    (
      rule Dom.vbrelation_Limit_vsubset_VsetI, 
      unfold dg_cs_simps, 
      insert dg_Dom_vrange dg_Obj_vsubset_Vset
    )
    (auto intro!: dg_Arr_vsubset_Vset)

lemma (in digraph) dg_Cod_vsubset_Vset: "ℭ⦇Cod⦈ ⊆∘ Vset α"
  by 
    (
      rule Cod.vbrelation_Limit_vsubset_VsetI, 
      unfold dg_cs_simps, 
      insert dg_Cod_vrange dg_Obj_vsubset_Vset
    )
    (auto intro!: dg_Arr_vsubset_Vset)

lemma (in digraph) dg_digraph_in_Vset_4: "ℭ ∈∘ Vset (α + 4ℕ)"
proof-
  note [folded VPow_iff, folded Vset_succ[OF Ord_α], dg_cs_intros] =
    dg_Obj_vsubset_Vset
    dg_Arr_vsubset_Vset
    dg_Dom_vsubset_Vset
    dg_Cod_vsubset_Vset
  show ?thesis
    by (subst dg_def, succ_of_numeral)
      (
        cs_concl 
          cs_simp: plus_V_succ_right V_cs_simps 
          cs_intro: dg_cs_intros V_cs_intros
      )
qed

lemma (in digraph) dg_Obj_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ⦇Obj⦈ ∈∘ Vset β"
  using assms dg_Obj_vsubset_Vset Vset_in_mono by auto

lemma (in digraph) dg_in_Obj_in_Vset[dg_cs_intros]:
  assumes "a ∈∘ ℭ⦇Obj⦈"
  shows "a ∈∘ Vset α"
  using assms dg_Obj_vsubset_Vset by auto

lemma (in digraph) dg_Arr_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ⦇Arr⦈ ∈∘ Vset β"
  using assms dg_Arr_vsubset_Vset Vset_in_mono by auto

lemma (in digraph) dg_in_Arr_in_Vset[dg_cs_intros]:
  assumes "a ∈∘ ℭ⦇Arr⦈"
  shows "a ∈∘ Vset α"
  using assms dg_Arr_vsubset_Vset by auto

lemma (in digraph) dg_Dom_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ⦇Dom⦈ ∈∘ Vset β"
  by (meson assms dg_Dom_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in digraph) dg_Cod_in_Vset:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ⦇Cod⦈ ∈∘ Vset β"
  by (meson assms dg_Cod_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in digraph) dg_in_Vset:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [dg_cs_intros] = 
    dg_Obj_in_Vset dg_Arr_in_Vset dg_Dom_in_Vset dg_Cod_in_Vset 
  from assms(2) show ?thesis
     by (subst dg_def) (cs_concl cs_intro: dg_cs_intros V_cs_intros)
 qed

lemma (in digraph) dg_digraph_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "digraph β ℭ"
proof(rule digraphI)
  show "vfsequence ℭ" by (simp add: vfsequence_axioms)
  show "ℭ⦇Obj⦈ ⊆∘ Vset β"
    by (rule vsubsetI) 
      (meson Vset_in_mono Vset_trans assms(2) dg_Obj_vsubset_Vset vsubsetE)
  fix A B assume "A ⊆∘ ℭ⦇Obj⦈" "B ⊆∘ ℭ⦇Obj⦈" "A ∈∘ Vset β" "B ∈∘ Vset β"
  then have "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ⊆∘ ℭ⦇Arr⦈" by auto
  moreover note dg_Arr_vsubset_Vset
  moreover have "Vset α ∈∘ Vset β" by (simp add: Vset_in_mono assms(2))
  ultimately show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset β" by auto
qed (auto simp: assms(1) dg_Dom_vrange dg_Cod_vrange dg_cs_simps)

lemma small_digraph[simp]: "small {ℭ. digraph α ℭ}"
proof(cases ‹𝒵 α›)
  case True
  with digraph.dg_in_Vset show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›] subsetI)
      (auto simp: 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{ℭ. digraph α ℭ} = {}" by auto
  then show ?thesis by simp
qed

lemma (in 𝒵) digraphs_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "set {ℭ. digraph α ℭ} ∈∘ Vset β"
proof(rule vsubset_in_VsetI)
  interpret β: 𝒵 β by (rule assms(1))
  show "set {ℭ. digraph α ℭ} ⊆∘ Vset (α + 4ℕ)"
  proof(intro vsubsetI)
    fix ℭ assume "ℭ ∈∘ set {ℭ. digraph α ℭ}"
    then interpret digraph α ℭ by simp
    show "ℭ ∈∘ Vset (α + 4ℕ)"
      unfolding VPow_iff by (rule dg_digraph_in_Vset_4)
  qed
  from assms(2) show "Vset (α + 4ℕ) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed

lemma digraph_if_digraph:
  assumes "digraph β ℭ"
    and "𝒵 α"
    and "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and "⋀A B. ⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹
      (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
  shows "digraph α ℭ"
proof-
  interpret digraph β ℭ by (rule assms(1))
  interpret α: 𝒵 α by (rule assms(2))
  show ?thesis
  proof(intro digraphI)
    show "vfsequence ℭ" by (simp add: vfsequence_axioms)
    show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
      if "A ⊆∘ ℭ⦇Obj⦈" "B ⊆∘ ℭ⦇Obj⦈" "A ∈∘ Vset α" "B ∈∘ Vset α" for A B
      by (rule assms(4)[OF that])
  qed (auto simp: assms(3) dg_Cod_vrange dg_cs_simps intro!: dg_Dom_vrange)
qed


text‹Further elementary properties.›

lemma (in digraph) dg_Dom_app_in_Obj:
  assumes "f ∈∘ ℭ⦇Arr⦈"
  shows "ℭ⦇Dom⦈⦇f⦈ ∈∘ ℭ⦇Obj⦈"
  using assms dg_Dom_vrange by (auto simp: Dom.vsv_vimageI2)

lemma (in digraph) dg_Cod_app_in_Obj:
  assumes "f ∈∘ ℭ⦇Arr⦈"
  shows "ℭ⦇Cod⦈⦇f⦈ ∈∘ ℭ⦇Obj⦈"
  using assms dg_Cod_vrange by (auto simp: Cod.vsv_vimageI2)

lemma (in digraph) dg_Arr_vempty_if_Obj_vempty:
  assumes "ℭ⦇Obj⦈ = 0"
  shows "ℭ⦇Arr⦈ = 0"
  by (metis assms eq0_iff dg_Cod_app_in_Obj)

lemma (in digraph) dg_Dom_vempty_if_Arr_vempty:
  assumes "ℭ⦇Arr⦈ = 0"
  shows "ℭ⦇Dom⦈ = 0"
  using assms Dom.vdomain_vrange_is_vempty 
  by (auto intro: Dom.vsv_vrange_vempty simp: dg_cs_simps)

lemma (in digraph) dg_Cod_vempty_if_Arr_vempty:
  assumes "ℭ⦇Arr⦈ = 0"
  shows "ℭ⦇Cod⦈ = 0"
  using assms Cod.vdomain_vrange_is_vempty 
  by (auto intro: Cod.vsv_vrange_vempty simp: dg_cs_simps)



subsection‹Opposite digraph›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›

definition op_dg :: "V ⇒ V"
  where "op_dg ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Cod⦈, ℭ⦇Dom⦈]∘"


text‹Components.›

lemma op_dg_components[dg_op_simps]:
  shows "op_dg ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
    and "op_dg ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
    and "op_dg ℭ⦇Dom⦈ = ℭ⦇Cod⦈"
    and "op_dg ℭ⦇Cod⦈ = ℭ⦇Dom⦈"
  unfolding op_dg_def dg_field_simps by (auto simp: nat_omega_simps)

lemma op_dg_component_intros[dg_op_intros]:
  shows "a ∈∘ ℭ⦇Obj⦈ ⟹ a ∈∘ op_dg ℭ⦇Obj⦈"
    and "f ∈∘ ℭ⦇Arr⦈ ⟹ f ∈∘ op_dg ℭ⦇Arr⦈"
  unfolding dg_op_simps by simp_all


text‹Elementary properties.›

lemma op_dg_is_arr[dg_op_simps]: "f : b ↦op_dg ℭ a ⟷ f : a ↦ℭ b"
  unfolding dg_op_simps is_arr_def by auto

lemmas [dg_op_intros] = op_dg_is_arr[THEN iffD2]

lemma op_dg_Hom[dg_op_simps]: "Hom (op_dg ℭ) a b = Hom ℭ b a"
  unfolding dg_op_simps by simp


subsubsection‹Further properties›

lemma (in digraph) digraph_op[dg_op_intros]: "digraph α (op_dg ℭ)"
proof(intro digraphI, unfold op_dg_components dg_op_simps)
  show "vfsequence (op_dg ℭ)" unfolding op_dg_def by simp
  show "vcard (op_dg ℭ) = 4ℕ"
    unfolding op_dg_def by (simp add: nat_omega_simps)
  fix A B assume "A ⊆∘ ℭ⦇Obj⦈" "B ⊆∘ ℭ⦇Obj⦈" "A ∈∘ Vset α" "B ∈∘ Vset α"
  then show "⋃∘((λa∈∘A. ⋃∘((λaa∈∘B. Hom ℭ aa a) `∘ B)) `∘ A) ∈∘ Vset α"
    by (subst vifunion_vifunion_flip) (intro dg_Hom_vifunion_in_Vset)
qed (auto simp: dg_Dom_vrange dg_Cod_vrange dg_Obj_vsubset_Vset dg_cs_simps)

lemmas digraph_op[dg_op_intros] = digraph.digraph_op

lemma (in digraph) dg_op_dg_op_dg[dg_op_simps]: "op_dg (op_dg ℭ) = ℭ"
  by (rule dg_eqI[of α], unfold dg_op_simps)
    (simp_all add: digraph_axioms digraph.digraph_op digraph_op)

lemmas dg_op_dg_op_dg[dg_op_simps] = digraph.dg_op_dg_op_dg

lemma eq_op_dg_iff[dg_op_simps]: 
  assumes "digraph α 𝔄" and "digraph α 𝔅"
  shows "op_dg 𝔄 = op_dg 𝔅 ⟷ 𝔄 = 𝔅"
proof
  interpret 𝔄: digraph α 𝔄 by (rule assms(1))
  interpret 𝔅: digraph α 𝔅 by (rule assms(2))
  assume prems: "op_dg 𝔄 = op_dg 𝔅"
  show "𝔄 = 𝔅"
  proof(rule dg_eqI[of α])
    from prems show 
      "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈" "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
      by (metis prems 𝔄.dg_op_dg_op_dg 𝔅.dg_op_dg_op_dg)+
  qed (simp_all add: assms)
qed auto

text‹\newpage›

end

Theory CZH_DG_Small_Digraph

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for digraphs›
theory CZH_DG_Small_Digraph
  imports CZH_DG_Digraph
begin



subsection‹Background›

named_theorems dg_small_cs_simps
named_theorems dg_small_cs_intros



subsection‹Tiny digraph›


subsubsection‹Definition and elementary properties›

locale tiny_digraph = 𝒵 α + vfsequence ℭ + Dom: vsv ‹ℭ⦇Dom⦈› + Cod: vsv ‹ℭ⦇Cod⦈› 
  for α ℭ +
  assumes tiny_dg_length[dg_cs_simps]: "vcard ℭ = 4ℕ"  
    and tiny_dg_Dom_vdomain[dg_cs_simps]: "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"    
    and tiny_dg_Dom_vrange: "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and tiny_dg_Cod_vdomain[dg_cs_simps]: "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and tiny_dg_Cod_vrange: "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and tiny_dg_Obj_in_Vset[dg_small_cs_intros]: "ℭ⦇Obj⦈ ∈∘ Vset α"
    and tiny_dg_Arr_in_Vset[dg_small_cs_intros]: "ℭ⦇Arr⦈ ∈∘ Vset α"

lemmas [dg_small_cs_intros] = 
  tiny_digraph.tiny_dg_Obj_in_Vset
  tiny_digraph.tiny_dg_Arr_in_Vset


text‹Rules.›

lemma (in tiny_digraph) tiny_digraph_axioms'[dg_small_cs_intros]:
  assumes "α' = α"
  shows "tiny_digraph α' ℭ"
  unfolding assms by (rule tiny_digraph_axioms)

mk_ide rf tiny_digraph_def[unfolded tiny_digraph_axioms_def]
  |intro tiny_digraphI|
  |dest tiny_digraphD[dest]|
  |elim tiny_digraphE[elim]|

lemma tiny_digraphI':
  assumes "digraph α ℭ" and "ℭ⦇Obj⦈ ∈∘ Vset α" and "ℭ⦇Arr⦈ ∈∘ Vset α"
  shows "tiny_digraph α ℭ"
  using assms by (meson digraphD(5,6,7,8,9) digraph_def tiny_digraphI)


text‹Elementary properties.›

sublocale tiny_digraph ⊆ digraph 
proof(rule digraphI)
  from tiny_dg_Obj_in_Vset show "ℭ⦇Obj⦈ ⊆∘ Vset α" by auto
  fix A B assume "A ⊆∘ ℭ⦇Obj⦈" "B ⊆∘ ℭ⦇Obj⦈" "A ∈∘ Vset α" "B ∈∘ Vset α" 
  then have "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ⊆∘ ℭ⦇Arr⦈" by auto
  with tiny_dg_Arr_in_Vset show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α" by blast
qed 
  (
    cs_concl 
      cs_simp: dg_cs_simps  
      cs_intro: tiny_dg_Cod_vrange tiny_dg_Dom_vrange dg_cs_intros V_cs_intros
  )+

lemmas (in tiny_digraph) tiny_dg_digraph = digraph_axioms

lemmas [dg_small_cs_intros] = tiny_digraph.tiny_dg_digraph


text‹Size.›

lemma (in tiny_digraph) tiny_dg_Dom_in_Vset: "ℭ⦇Dom⦈ ∈∘ Vset α"
proof-
  from 𝒵_Limit_αω have "𝒟∘ (ℭ⦇Dom⦈) ∈∘ Vset α"  
    by (simp add: tiny_dg_Arr_in_Vset dg_cs_simps)
  moreover from tiny_dg_Dom_vrange have "ℛ∘ (ℭ⦇Dom⦈) ∈∘ Vset α" 
    by (auto intro: tiny_dg_Obj_in_Vset)
  ultimately show ?thesis 
    by (simp add: Dom.vbrelation_Limit_in_VsetI 𝒵_Limit_αω)
qed

lemma (in tiny_digraph) tiny_dg_Cod_in_Vset: "ℭ⦇Cod⦈ ∈∘ Vset α"
proof-
  from 𝒵_Limit_αω have "𝒟∘ (ℭ⦇Cod⦈) ∈∘ Vset α"  
    by (simp add: tiny_dg_Arr_in_Vset dg_cs_simps)
  moreover from tiny_dg_Cod_vrange have "ℛ∘ (ℭ⦇Cod⦈) ∈∘ Vset α" 
    by (auto intro: tiny_dg_Obj_in_Vset)
  ultimately show ?thesis 
    by (simp add: Cod.vbrelation_Limit_in_VsetI 𝒵_Limit_αω)
qed

lemma (in tiny_digraph) tiny_dg_in_Vset: "ℭ ∈∘ Vset α"
proof-
  note [dg_cs_intros] = 
    tiny_dg_Obj_in_Vset 
    tiny_dg_Arr_in_Vset
    tiny_dg_Dom_in_Vset
    tiny_dg_Cod_in_Vset
  show ?thesis
    by (subst dg_def) (cs_concl cs_intro: dg_cs_intros V_cs_intros)
qed

lemma small_tiny_digraphs[simp]: "small {ℭ. tiny_digraph α ℭ}"
proof(rule down)
  show "{ℭ. tiny_digraph α ℭ} ⊆ elts (set {ℭ. digraph α ℭ})" 
    by (auto intro: dg_small_cs_intros)
qed

lemma tiny_digraphs_vsubset_Vset: "set {ℭ. tiny_digraph α ℭ} ⊆∘ Vset α"
  by (rule vsubsetI) (simp add: tiny_digraph.tiny_dg_in_Vset)

lemma (in digraph) dg_tiny_digraph_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_digraph β ℭ"
proof(intro tiny_digraphI')
  interpret β: 𝒵 β by (rule assms(1))
  show "digraph β ℭ"
    by (intro dg_digraph_if_ge_Limit)
      (use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
  show "ℭ⦇Obj⦈ ∈∘ Vset β" "ℭ⦇Arr⦈ ∈∘ Vset β" 
    by (auto simp: β.𝒵_β assms(2) dg_Obj_in_Vset dg_Arr_in_Vset)
qed


subsubsection‹Opposite tiny digraph›

lemma (in tiny_digraph) tiny_digraph_op: "tiny_digraph α (op_dg ℭ)"
  by (intro tiny_digraphI', unfold dg_op_simps)
    (auto simp: tiny_dg_Obj_in_Vset tiny_dg_Arr_in_Vset dg_cs_simps dg_op_intros)

lemmas tiny_digraph_op[dg_op_intros] = tiny_digraph.tiny_digraph_op



subsection‹Finite digraph›


subsubsection‹Definition and elementary properties›


text‹
A finite digraph is a generalization of the concept of a finite category,
as presented in nLab 
\cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/finite+category}
}.
›

locale finite_digraph = digraph α ℭ for α ℭ +
  assumes fin_dg_Obj_vfinite[dg_small_cs_intros]: "vfinite (ℭ⦇Obj⦈)"
    and fin_dg_Arr_vfinite[dg_small_cs_intros]: "vfinite (ℭ⦇Arr⦈)"

lemmas [dg_small_cs_intros] = 
  finite_digraph.fin_dg_Obj_vfinite
  finite_digraph.fin_dg_Arr_vfinite


text‹Rules.›

lemma (in finite_digraph) finite_digraph_axioms'[dg_small_cs_intros]:
  assumes "α' = α"
  shows "finite_digraph α' ℭ"
  unfolding assms by (rule finite_digraph_axioms)

mk_ide rf finite_digraph_def[unfolded finite_digraph_axioms_def]
  |intro finite_digraphI|
  |dest finite_digraphD[dest]|
  |elim finite_digraphE[elim]|


text‹Elementary properties.›

sublocale finite_digraph ⊆ tiny_digraph 
proof(rule tiny_digraphI')
  show "ℭ⦇Obj⦈ ∈∘ Vset α"
    by
      (
        cs_concl cs_intro: 
          dg_small_cs_intros V_cs_intros 
          dg_Obj_vsubset_Vset Limit_vfinite_in_VsetI
      )
  show "ℭ⦇Arr⦈ ∈∘ Vset α"
    by 
      (
        cs_concl cs_intro: 
          dg_small_cs_intros V_cs_intros 
          dg_Arr_vsubset_Vset Limit_vfinite_in_VsetI
      )
qed (auto intro: dg_cs_intros)

lemmas (in finite_digraph) fin_dg_tiny_digraph = tiny_digraph_axioms

lemmas [dg_small_cs_intros] = finite_digraph.fin_dg_tiny_digraph


text‹Size.›

lemma small_finite_digraphs[simp]: "small {ℭ. finite_digraph α ℭ}"
proof(rule down)
  show "{ℭ. finite_digraph α ℭ} ⊆ elts (set {ℭ. digraph α ℭ})" 
    by (auto intro: dg_cs_intros)
qed 

lemma finite_digraphs_vsubset_Vset: "set {ℭ. finite_digraph α ℭ} ⊆∘ Vset α"
  by 
    (
      force simp: 
        tiny_digraph.tiny_dg_in_Vset finite_digraph.fin_dg_tiny_digraph
    )


subsubsection‹Opposite finite digraph›

lemma (in finite_digraph) fininte_digraph_op: "finite_digraph α (op_dg ℭ)"
  by (intro finite_digraphI, unfold dg_op_simps)
    (auto simp: dg_small_cs_intros dg_op_intros)

lemmas fininte_digraph_op[dg_op_intros] = finite_digraph.fininte_digraph_op

text‹\newpage›

end

Theory CZH_DG_DGHM

(* Copyright 2021 (C) Mihails Milehins *)

section‹Homomorphism of digraphs›
theory CZH_DG_DGHM
  imports CZH_DG_Digraph
begin



subsection‹Background›

named_theorems dghm_cs_simps
named_theorems dghm_cs_intros

named_theorems dg_cn_cs_simps
named_theorems dg_cn_cs_intros

named_theorems dghm_field_simps

definition ObjMap :: V where [dghm_field_simps]: "ObjMap = 0"
definition ArrMap :: V where [dghm_field_simps]: "ArrMap = 1ℕ"
definition HomDom :: V where [dghm_field_simps]: "HomDom = 2ℕ"
definition HomCod :: V where [dghm_field_simps]: "HomCod = 3ℕ"



subsection‹Definition and elementary properties›


text‹
A homomorphism of digraphs, as presented in this work, can be seen as a
generalization of the concept of a functor between categories, as presented in
Chapter I-3 in \cite{mac_lane_categories_2010}, to digraphs. 
The generalization is performed by removing the axioms (1) from the definition.
It is expected that the resulting definition is consistent with the conventional
notion of a homomorphism of digraphs in graph theory, but further details 
are considered to be outside of the scope of this work.

The definition of a digraph homomorphism is parameterized by a limit ordinal
‹α› such that ‹ω < α›. Such digraph homomorphisms are referred to either as
‹α›-digraph homomorphisms or homomorphisms of ‹α›-digraphs.

Following \cite{mac_lane_categories_2010}, all digraph homomorphisms are 
covariant (see Chapter II-2). However, a special notation is adapted for the 
digraph homomorphisms from an opposite digraph. Normally, such 
digraph homomorphisms will be referred to as the contravariant digraph 
homomorphisms, but this convention will not be enforced.
›

locale is_dghm = 
  𝒵 α + vfsequence 𝔉 + HomDom: digraph α 𝔄 + HomCod: digraph α 𝔅 
  for α 𝔄 𝔅 𝔉 +
  assumes dghm_length[dg_cs_simps]: "vcard 𝔉 = 4ℕ"  
    and dghm_HomDom[dg_cs_simps]: "𝔉⦇HomDom⦈ = 𝔄"
    and dghm_HomCod[dg_cs_simps]: "𝔉⦇HomCod⦈ = 𝔅"
    and dghm_ObjMap_vsv: "vsv (𝔉⦇ObjMap⦈)"
    and dghm_ArrMap_vsv: "vsv (𝔉⦇ArrMap⦈)"
    and dghm_ObjMap_vdomain[dg_cs_simps]: "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    and dghm_ObjMap_vrange: "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 𝔅⦇Obj⦈"
    and dghm_ArrMap_vdomain[dg_cs_simps]: "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    and dghm_ArrMap_is_arr: 
      "f : a ↦𝔄 b ⟹ 𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"

syntax "_is_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦DGı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DGα 𝔅" ⇌ "CONST is_dghm α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦DGα 𝔅"

syntax "_is_cn_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ DG↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 DG↦↦α 𝔅" ⇀ "CONST is_cn_dghm α 𝔄 𝔅 𝔉"

abbreviation all_dghms :: "V ⇒ V"
  where "all_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅}"

abbreviation dghms :: "V ⇒ V ⇒ V ⇒ V"
  where "dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦DGα 𝔅}"

sublocale is_dghm ⊆ ObjMap: vsv ‹𝔉⦇ObjMap⦈›
  rewrites "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
  by (rule dghm_ObjMap_vsv) (simp add: dg_cs_simps)

sublocale is_dghm ⊆ ArrMap: vsv ‹𝔉⦇ArrMap⦈›
  rewrites "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
  by (rule dghm_ArrMap_vsv) (simp add: dg_cs_simps)

lemmas [dg_cs_simps] =
  is_dghm.dghm_HomDom
  is_dghm.dghm_HomCod
  is_dghm.dghm_ObjMap_vdomain
  is_dghm.dghm_ArrMap_vdomain

lemma (in is_dghm) dghm_ArrMap_is_arr''[dg_cs_intros]:
  assumes "f : a ↦𝔄 b" and "𝔉f = 𝔉⦇ArrMap⦈⦇f⦈"
  shows "𝔉f : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"
  using assms(1) unfolding assms(2) by (rule dghm_ArrMap_is_arr)

lemma (in is_dghm) dghm_ArrMap_is_arr'[dg_cs_intros]:
  assumes "f : a ↦𝔄 b"
    and "A = 𝔉⦇ObjMap⦈⦇a⦈"
    and "B = 𝔉⦇ObjMap⦈⦇b⦈"
  shows "𝔉⦇ArrMap⦈⦇f⦈ : A ↦𝔅 B"
  using assms(1) unfolding assms(2,3) by (rule dghm_ArrMap_is_arr) 

lemmas [dg_cs_intros] = is_dghm.dghm_ArrMap_is_arr'


text‹Rules.›

lemma (in is_dghm) is_dghm_axioms'[dg_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DGα' 𝔅'"
  unfolding assms by (rule is_dghm_axioms)

mk_ide rf is_dghm_def[unfolded is_dghm_axioms_def]
  |intro is_dghmI|
  |dest is_dghmD[dest]|
  |elim is_dghmE[elim]|

lemmas [dg_cs_intros] = is_dghmD(3,4)


text‹Elementary properties.›

lemma dghm_eqI:
  assumes "𝔊 : 𝔄 ↦↦DGα 𝔅" 
    and "𝔉 : ℭ ↦↦DGα 𝔇"
    and "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
    and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    and "𝔄 = ℭ"
    and "𝔅 = 𝔇"
  shows "𝔊 = 𝔉"
proof-
  interpret L: is_dghm α 𝔄 𝔅 𝔊 by (rule assms(1))
  interpret R: is_dghm α ℭ 𝔇 𝔉 by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ 𝔊 = 4ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
    from assms(5,6) have sup: "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈" 
      by (simp_all add: dg_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔊 ⟹ 𝔊⦇a⦈ = 𝔉⦇a⦈" for a 
      by (unfold dom, elim_in_numeral, insert assms(3,4) sup)
        (auto simp: dghm_field_simps)
  qed (cs_concl cs_simp: dg_cs_simps V_cs_simps cs_intro: V_cs_intros)+
qed

lemma (in is_dghm) dghm_def: "𝔉 = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ 𝔉 = 4ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
  have dom_rhs: "𝒟∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘ = 4ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ 𝔉 = 𝒟∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘"
    unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
  show "a ∈∘ 𝒟∘ 𝔉 ⟹ 𝔉⦇a⦈ = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘⦇a⦈" 
    for a
    by (unfold dom_lhs, elim_in_numeral, unfold dghm_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in is_dghm) dghm_ObjMap_app_in_HomCod_Obj[dg_cs_intros]:
  assumes "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔉⦇ObjMap⦈⦇a⦈ ∈∘ 𝔅⦇Obj⦈"
  using assms dghm_ObjMap_vrange by (blast dest: ObjMap.vsv_vimageI2)

lemmas [dg_cs_intros] = is_dghm.dghm_ObjMap_app_in_HomCod_Obj

lemma (in is_dghm) dghm_ArrMap_vrange: "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ 𝔅⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
  fix f assume "f ∈∘ 𝔄⦇Arr⦈"
  then obtain a b where "f : a ↦𝔄 b" by auto
  then have "𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈" 
    by (cs_concl cs_intro: dg_cs_intros)
  then show "𝔉⦇ArrMap⦈⦇f⦈ ∈∘ 𝔅⦇Arr⦈" by auto
qed auto

lemma (in is_dghm) dghm_ArrMap_app_in_HomCod_Arr[dg_cs_intros]:
  assumes "a ∈∘ 𝔄⦇Arr⦈"
  shows "𝔉⦇ArrMap⦈⦇a⦈ ∈∘ 𝔅⦇Arr⦈"
  using assms dghm_ArrMap_vrange by (blast dest: ArrMap.vsv_vimageI2)

lemmas [dg_cs_intros] = is_dghm.dghm_ArrMap_app_in_HomCod_Arr


text‹Size.›

lemma (in is_dghm) dghm_ObjMap_vsubset_Vset: "𝔉⦇ObjMap⦈ ⊆∘ Vset α"
  by 
    (
      rule ObjMap.vbrelation_Limit_vsubset_VsetI, 
      insert dghm_ObjMap_vrange HomCod.dg_Obj_vsubset_Vset
    )
    (auto intro!: HomDom.dg_Obj_vsubset_Vset)

lemma (in is_dghm) dghm_ArrMap_vsubset_Vset: "𝔉⦇ArrMap⦈ ⊆∘ Vset α"
  by 
    (
      rule ArrMap.vbrelation_Limit_vsubset_VsetI, 
      insert dghm_ArrMap_vrange HomCod.dg_Arr_vsubset_Vset
    )
    (auto intro!: HomDom.dg_Arr_vsubset_Vset)

lemma (in is_dghm) dghm_ObjMap_in_Vset: 
  assumes "α ∈∘ β"
  shows "𝔉⦇ObjMap⦈ ∈∘ Vset β" 
  by (meson assms dghm_ObjMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in is_dghm) dghm_ArrMap_in_Vset:
  assumes  "α ∈∘ β"
  shows "𝔉⦇ArrMap⦈ ∈∘ Vset β"
  by (meson assms dghm_ArrMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in is_dghm) dghm_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [dg_cs_intros] = 
    dghm_ObjMap_in_Vset dghm_ArrMap_in_Vset HomDom.dg_in_Vset HomCod.dg_in_Vset
  from assms(2) show ?thesis
    by (subst dghm_def) 
      (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed

lemma (in is_dghm) dghm_is_dghm_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 : 𝔄 ↦↦DGβ 𝔅"
proof(rule is_dghmI)
  from is_dghm_axioms assms show "digraph β 𝔄"
    by (cs_concl cs_intro: digraph.dg_digraph_if_ge_Limit dg_cs_intros)
  from is_dghm_axioms assms show "digraph β 𝔅"
    by (cs_concl cs_intro: digraph.dg_digraph_if_ge_Limit dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: assms(1) dg_cs_intros V_cs_intros dghm_ObjMap_vrange)+

lemma small_all_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅}"
proof(cases ‹𝒵 α›)
  case True
  from is_dghm.dghm_in_Vset show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›] subsetI)
      (auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅} = {}" by auto
  then show ?thesis by simp
qed

lemma (in is_dghm) dghm_in_Vset_7: "𝔉 ∈∘ Vset (α + 7ℕ)"
proof-
  note [folded VPow_iff, folded Vset_succ[OF Ord_α], dg_cs_intros] =
    dghm_ObjMap_vsubset_Vset 
    dghm_ArrMap_vsubset_Vset 
  from HomDom.dg_digraph_in_Vset_4 have [dg_cs_intros]:
    "𝔄 ∈∘ Vset (succ (succ (succ (succ α))))"
    by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
  from HomCod.dg_digraph_in_Vset_4 have [dg_cs_intros]:
    "𝔅 ∈∘ Vset (succ (succ (succ (succ α))))"
    by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
  show ?thesis
    by (subst dghm_def, succ_of_numeral)
      (
        cs_concl 
          cs_simp: plus_V_succ_right V_cs_simps dg_cs_simps 
          cs_intro: dg_cs_intros V_cs_intros
      )
qed

lemma (in 𝒵) all_dghms_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "all_dghms α ∈∘ Vset β"
proof(rule vsubset_in_VsetI)
  interpret β: 𝒵 β by (rule assms(1))
  show "all_dghms α ⊆∘ Vset (α + 7ℕ)"
  proof(intro vsubsetI)
    fix 𝔉 assume "𝔉 ∈∘ all_dghms α"
    then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦DGα 𝔅" by clarsimp
    interpret is_dghm α 𝔄 𝔅 𝔉 using 𝔉 by simp
    show "𝔉 ∈∘ Vset (α + 7ℕ)" by (rule dghm_in_Vset_7)
  qed
  from assms(2) show "Vset (α + 7ℕ) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed

lemma small_dghms[simp]: "small {𝔉. 𝔉 : 𝔄 ↦↦DGα 𝔅}"
  by (rule down[of _ ‹set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅}›]) auto


text‹Further elementary properties.›

lemma (in is_dghm) dghm_is_arr_HomCod: 
  assumes "f : a ↦𝔄 b"
  shows "𝔉⦇ArrMap⦈⦇f⦈ ∈∘ 𝔅⦇Arr⦈" "𝔉⦇ObjMap⦈⦇a⦈ ∈∘ 𝔅⦇Obj⦈" "𝔉⦇ObjMap⦈⦇b⦈ ∈∘ 𝔅⦇Obj⦈" 
  using assms by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+ 

lemma (in is_dghm) dghm_vimage_dghm_ArrMap_vsubset_Hom:
  assumes "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔄⦇Obj⦈"
  shows "𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b ⊆∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
proof(intro vsubsetI)
  fix g assume "g ∈∘ 𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b"
  then obtain f where "f ∈∘ Hom (𝔉⦇HomDom⦈) a b" and "g = 𝔉⦇ArrMap⦈⦇f⦈" 
    by (auto simp: dg_cs_simps)
  then show "g ∈∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
    by (simp add: dghm_ArrMap_is_arr dg_cs_simps)
qed



subsection‹Opposite digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›

definition op_dghm :: "V ⇒ V"
  where "op_dghm 𝔉 =
    [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, op_dg (𝔉⦇HomDom⦈), op_dg (𝔉⦇HomCod⦈)]∘"


text‹Components.›

lemma op_dghm_components[dg_op_simps]:
  shows "op_dghm 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
    and "op_dghm 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    and "op_dghm 𝔉⦇HomDom⦈ = op_dg (𝔉⦇HomDom⦈)"
    and "op_dghm 𝔉⦇HomCod⦈ = op_dg (𝔉⦇HomCod⦈)"
  unfolding op_dghm_def dghm_field_simps by (auto simp: nat_omega_simps)


subsubsection‹Further properties›

lemma (in is_dghm) is_dghm_op: "op_dghm 𝔉 : op_dg 𝔄 ↦↦DGα op_dg 𝔅"
proof(intro is_dghmI, unfold dg_op_simps)
  show "vfsequence (op_dghm 𝔉)" unfolding op_dghm_def by simp
  show "vcard (op_dghm 𝔉) = 4ℕ"
    unfolding op_dghm_def by (auto simp: nat_omega_simps)
qed 
  (
    cs_concl 
      cs_intro: dghm_ObjMap_vrange dg_cs_intros dg_op_intros V_cs_intros 
      cs_simp: dg_cs_simps dg_op_simps
  )+

lemma (in is_dghm) is_dghm_op'[dg_op_intros]:  
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DGα' 𝔅'"
  unfolding assms by (rule is_dghm_op)

lemmas is_dghm_op[dg_op_intros] = is_dghm.is_dghm_op'

lemma (in is_dghm) dghm_op_dghm_op_dghm[dg_op_simps]: "op_dghm (op_dghm 𝔉) = 𝔉" 
  using is_dghm_axioms
  by 
    (
      cs_concl 
        cs_simp: dg_op_simps 
        cs_intro: dg_op_intros dghm_eqI[where 𝔉=𝔉]
    )

lemmas dghm_op_dghm_op_dghm[dg_op_simps] = is_dghm.dghm_op_dghm_op_dghm

lemma eq_op_dghm_iff[dg_op_simps]: 
  assumes "𝔊 : 𝔄 ↦↦DGα 𝔅" and "𝔉 : ℭ ↦↦DGα 𝔇"
  shows "op_dghm 𝔊 = op_dghm 𝔉 ⟷ 𝔊 = 𝔉"
proof
  interpret L: is_dghm α 𝔄 𝔅 𝔊 by (rule assms(1))
  interpret R: is_dghm α ℭ 𝔇 𝔉 by (rule assms(2))
  assume prems: "op_dghm 𝔊 = op_dghm 𝔉"
  show "𝔊 = 𝔉"
  proof(rule dghm_eqI[OF assms])
    from prems R.dghm_op_dghm_op_dghm L.dghm_op_dghm_op_dghm show 
      "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
      by metis+
    from prems R.dghm_op_dghm_op_dghm L.dghm_op_dghm_op_dghm have 
      "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
      by auto
    then show "𝔄 = ℭ" "𝔅 = 𝔇" by (auto simp: dg_cs_simps)
  qed
qed auto



subsection‹Composition of covariant digraph homomorphisms›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

definition dghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘DGHM› 55)
  where "𝔊 ∘DGHM 𝔉 =
    [𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈, 𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔊⦇HomCod⦈]∘"


text‹Components.›

lemma dghm_comp_components:
  shows "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈"
    and "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: "(𝔊 ∘DGHM 𝔉)⦇HomDom⦈ = 𝔉⦇HomDom⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: "(𝔊 ∘DGHM 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
  unfolding dghm_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

lemma dghm_comp_ObjMap_vsv[dg_cs_intros]: 
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "vsv ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis by (cs_concl cs_simp: dghm_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_comp_ObjMap_vdomain[dg_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝒟∘ ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
        cs_intro: is_dghm.dghm_ObjMap_vrange
    )

lemma dghm_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_comp_components 
        cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros
    )

lemma dghm_comp_ObjMap_app[dg_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  from assms(3) show "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈" 
    by 
      (
        cs_concl 
          cs_simp: dghm_comp_components dg_cs_simps V_cs_simps 
          cs_intro: V_cs_intros dg_cs_intros
      )
qed


subsubsection‹Arrow map›

lemma dghm_comp_ArrMap_vsv[dg_cs_intros]: 
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "vsv ((𝔊 ∘DGHM 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis by (cs_concl cs_simp: dghm_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_comp_ArrMap_vdomain[dg_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝒟∘ ((𝔊 ∘DGHM 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
        cs_intro: is_dghm.dghm_ArrMap_vrange
    )

lemma dghm_comp_ArrMap_vrange[dg_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((𝔊 ∘DGHM 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_comp_components 
        cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros
    )

lemma dghm_comp_ArrMap_app[dg_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅" and "f ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
  interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  from assms(3) show "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
    by 
      (
        cs_concl 
          cs_simp: dghm_comp_components dg_cs_simps V_cs_simps 
          cs_intro: V_cs_intros dg_cs_intros
      )
qed


subsubsection‹Opposite of the composition of covariant digraph homomorphisms›

lemma op_dghm_dghm_comp[dg_op_simps]: 
  "op_dghm (𝔊 ∘DGHM 𝔉) = op_dghm 𝔊 ∘DGHM op_dghm 𝔉"
  unfolding dghm_comp_def op_dghm_def dghm_field_simps
  by (simp add: nat_omega_simps)


subsubsection‹Further properties›

lemma dghm_comp_is_dghm[dg_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DGα ℭ"
proof-
  interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
  proof(intro is_dghmI is_dghmI, unfold dg_cs_simps)  
    show "vfsequence (𝔊 ∘DGHM 𝔉)" unfolding dghm_comp_def by simp
    show "vcard (𝔊 ∘DGHM 𝔉) = 4ℕ" 
      unfolding dghm_comp_def by (simp add: nat_omega_simps)
    fix f a b assume "f : a ↦𝔄 b"
    with assms show "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇f⦈ : 
      (𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ ↦ℭ (𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed 
    (
      use assms in 
        ‹
          cs_concl
            cs_intro: dg_cs_intros dghm_comp_ObjMap_vrange 
            cs_simp: dg_cs_simps
        ›
    )+
qed

lemma dghm_comp_assoc[dg_cs_simps]:
  assumes "ℌ : ℭ ↦↦DGα 𝔇" and "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "(ℌ ∘DGHM 𝔊) ∘DGHM 𝔉 = ℌ ∘DGHM (𝔊 ∘DGHM 𝔉)"
proof(rule dghm_eqI [of α 𝔄 𝔇 _ 𝔄 𝔇])
  show "(ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ObjMap⦈ = (ℌ ∘DGHM (𝔊 ∘DGHM 𝔉))⦇ObjMap⦈"
  proof(rule vsv_eqI)
    show "(ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = (ℌ ∘DGHM (𝔊 ∘DGHM 𝔉))⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ObjMap⦈)" for a 
      using that assms
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (use assms in ‹cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros›)+
  show "(ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ = (ℌ ∘DGHM (𝔊 ∘DGHM 𝔉))⦇ArrMap⦈"
  proof(rule vsv_eqI)
    show "(ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇a⦈ = (ℌ ∘DGHM (𝔊 ∘DGHM 𝔉))⦇ArrMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((ℌ ∘DGHM 𝔊 ∘DGHM 𝔉)⦇ArrMap⦈)" for a 
      using that assms
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (use assms in ‹cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros›)+
qed (use assms in ‹cs_concl cs_intro: dg_cs_intros›)+



subsection‹Composition of contravariant digraph homomorphisms›


subsubsection‹Definition and elementary properties›


text‹See section 1.2 in \cite{bodo_categories_1970}.›

definition dghm_cn_comp :: "V ⇒ V ⇒ V" (infixl ‹DGHM∘› 55)
  where "𝔊 DGHM∘ 𝔉 =
    [
      𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈,
      𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈,
      op_dg (𝔉⦇HomDom⦈), 
      𝔊⦇HomCod⦈
    ]∘"


text‹Components.›

lemma dghm_cn_comp_components:
  shows "(𝔊 DGHM∘ 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈"
    and "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈"
    and [dg_cn_cs_simps]: "(𝔊 DGHM∘ 𝔉)⦇HomDom⦈ = op_dg (𝔉⦇HomDom⦈)"
    and [dg_cn_cs_simps]: "(𝔊 DGHM∘ 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
  unfolding dghm_cn_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map: two contravariant digraph homomorphisms›

lemma dghm_cn_comp_ObjMap_vsv[dg_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "vsv ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
    by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_cn_comp_ObjMap_vdomain[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "𝒟∘ ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
        cs_intro: is_dghm.dghm_ObjMap_vrange 
    )

lemma dghm_cn_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "ℛ∘ ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components
        cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros 
    )

lemma dghm_cn_comp_ObjMap_app[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
  from assms(3) show "(𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
    by 
      (
        cs_concl 
          cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps 
          cs_intro: V_cs_intros dg_cs_intros
      )
qed


subsubsection‹Arrow map: two contravariant digraph homomorphisms›

lemma dghm_cn_comp_ArrMap_vsv[dg_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "vsv ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
    by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_cn_comp_ArrMap_vdomain[dg_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "𝒟∘ ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
        cs_intro: is_dghm.dghm_ArrMap_vrange 
    )

lemma dghm_cn_comp_ArrMap_vrange:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "ℛ∘ ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components
        cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros 
    )

lemma dghm_cn_comp_ArrMap_app[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅" and "a ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
  from assms(3) show "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
    by 
      (
        cs_concl 
          cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps 
          cs_intro: V_cs_intros dg_cs_intros
      )
qed


subsubsection‹Object map: contravariant and covariant digraph homomorphisms›

lemma dghm_cn_cov_comp_ObjMap_vsv[dg_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "vsv ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
    by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_cn_cov_comp_ObjMap_vdomain[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝒟∘ ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
        cs_intro: is_dghm.dghm_ObjMap_vrange 
    )

lemma dghm_cn_cov_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((𝔊 DGHM∘ 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
  using assms
  by
    (
      cs_concl
        cs_simp: dghm_cn_comp_components
        cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros 
    )

lemma dghm_cn_cov_comp_ObjMap_app[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  from assms show "(𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈" 
    by 
      (
        cs_concl 
          cs_simp: dghm_cn_comp_components dg_cs_simps V_cs_simps 
          cs_intro: V_cs_intros dg_op_intros dg_cs_intros
      )
qed


subsubsection‹Arrow map: contravariant and covariant digraph homomorphisms›

lemma dghm_cn_cov_comp_ArrMap_vsv[dg_cn_cs_intros]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "vsv ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
    by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed

lemma dghm_cn_cov_comp_ArrMap_vdomain[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝒟∘ ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
        cs_intro: is_dghm.dghm_ArrMap_vrange 
    )

lemma dghm_cn_cov_comp_ArrMap_vrange:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((𝔊 DGHM∘ 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
  using assms 
  by 
    (
      cs_concl 
        cs_simp: dghm_cn_comp_components
        cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros 
    )

lemma dghm_cn_cov_comp_ArrMap_app[dg_cn_cs_simps]:
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅" and "a ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  from assms(3) show "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈" 
    by 
      (
        cs_concl 
          cs_simp: dghm_cn_comp_components dg_cs_simps V_cs_simps 
          cs_intro: V_cs_intros dg_op_intros dg_cs_intros
      )
qed


subsubsection‹
Opposite of the contravariant composition of the digraph homomorphisms
›

lemma op_dghm_dghm_cn_comp[dg_op_simps]: 
  "op_dghm (𝔊 DGHM∘ 𝔉) = op_dghm 𝔊 DGHM∘ op_dghm 𝔉"
  unfolding op_dghm_def dghm_cn_comp_def dghm_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹Further properties›

lemma dghm_cn_comp_is_dghm[dg_cn_cs_intros]:
  ―‹See section 1.2 in \cite{bodo_categories_1970}.›
  assumes "digraph α 𝔄" and "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "𝔊 DGHM∘ 𝔉 : 𝔄 ↦↦DGα ℭ"
proof-
  interpret 𝔄: digraph α 𝔄 by (rule assms(1))
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 using assms(2) by auto
  interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 using assms(3) by auto
  show ?thesis
  proof(intro is_dghmI, unfold dg_op_simps dg_cs_simps dg_cn_cs_simps)
    show "vfsequence (𝔊 DGHM∘ 𝔉)" unfolding dghm_cn_comp_def by auto
    show "vcard (𝔊 DGHM∘ 𝔉) = 4ℕ"
      unfolding dghm_cn_comp_def by (simp add: nat_omega_simps)
    fix f a b assume "f : a ↦𝔄 b"
    with assms show "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇f⦈ :
      (𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ ↦ℭ (𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇b⦈"
      by 
        (
          cs_concl 
            cs_simp: dg_cn_cs_simps  
            cs_intro: dg_cs_intros dg_op_intros
        )
  qed 
    ( 
      cs_concl 
        cs_simp: dg_cs_simps dg_cn_cs_simps 
        cs_intro: dghm_cn_comp_ObjMap_vrange dg_cs_intros dg_cn_cs_intros
    )+
qed

lemma dghm_cn_cov_comp_is_dghm[dg_cn_cs_intros]:
  ―‹See section 1.2 in \cite{bodo_categories_1970}.›
  assumes "𝔊 : 𝔅 DG↦↦α ℭ" and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "𝔊 DGHM∘ 𝔉 : 𝔄 DG↦↦α ℭ"
proof-
  interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
  proof(intro is_dghmI, unfold dg_op_simps dg_cs_simps)
    show "vfsequence (𝔊 DGHM∘ 𝔉)" unfolding dghm_cn_comp_def by simp
    show "vcard (𝔊 DGHM∘ 𝔉) = 4ℕ" 
      unfolding dghm_cn_comp_def by (auto simp: nat_omega_simps)
    fix f b a assume "f : b ↦𝔄 a"
    with assms show "(𝔊 DGHM∘ 𝔉)⦇ArrMap⦈⦇f⦈ : 
      (𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇a⦈ ↦ℭ (𝔊 DGHM∘ 𝔉)⦇ObjMap⦈⦇b⦈"
      by (cs_concl cs_simp: dg_cn_cs_simps dg_op_simps cs_intro: dg_cs_intros)
  qed
    ( 
      cs_concl 
        cs_simp: dg_cs_simps dg_cn_cs_simps
        cs_intro:
          dghm_cn_cov_comp_ObjMap_vrange 
          dg_cs_intros dg_cn_cs_intros dg_op_intros 
    )+
qed

lemma dghm_cov_cn_comp_is_dghm:
  ―‹See section 1.2 in \cite{bodo_categories_1970}›
  assumes "𝔊 : 𝔅 ↦↦DGα ℭ" and "𝔉 : 𝔄 DG↦↦α 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 DG↦↦α ℭ"
  using assms by (rule dghm_comp_is_dghm)



subsection‹Identity digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

definition dghm_id :: "V ⇒ V"
  where "dghm_id ℭ = [vid_on (ℭ⦇Obj⦈), vid_on (ℭ⦇Arr⦈), ℭ, ℭ]∘"


text‹Components.›

lemma dghm_id_components:
  shows "dghm_id ℭ⦇ObjMap⦈ = vid_on (ℭ⦇Obj⦈)" 
    and "dghm_id ℭ⦇ArrMap⦈ = vid_on (ℭ⦇Arr⦈)" 
    and [dg_shared_cs_simps, dg_cs_simps]: "dghm_id ℭ⦇HomDom⦈ = ℭ"
    and [dg_shared_cs_simps, dg_cs_simps]: "dghm_id ℭ⦇HomCod⦈ = ℭ" 
  unfolding dghm_id_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_id_components(1)[folded VLambda_vid_on]
  |vsv dghm_id_ObjMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
  |vdomain dghm_id_ObjMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
  |app dghm_id_ObjMap_app[dg_shared_cs_simps, dg_cs_simps]|

lemma dghm_id_ObjMap_vrange[dg_shared_cs_simps, dg_cs_simps]: 
  "ℛ∘ (dghm_id ℭ⦇ObjMap⦈) = ℭ⦇Obj⦈"
  unfolding dghm_id_components by simp


subsubsection‹Arrow map›

mk_VLambda dghm_id_components(2)[folded VLambda_vid_on]
  |vsv dghm_id_ArrMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
  |vdomain dghm_id_ArrMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
  |app dghm_id_ArrMap_app[dg_shared_cs_simps, dg_cs_simps]|

lemma dghm_id_ArrMap_vrange[dg_shared_cs_simps, dg_cs_simps]: 
  "ℛ∘ (dghm_id ℭ⦇ArrMap⦈) = ℭ⦇Arr⦈"
  unfolding dghm_id_components by simp


subsubsection‹Opposite identity digraph homomorphism›

lemma op_dghm_dghm_id[dg_op_simps]: "op_dghm (dghm_id ℭ) = dghm_id (op_dg ℭ)"
  unfolding dghm_id_def op_dg_def op_dghm_def dghm_field_simps dg_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹An identity digraph homomorphism is a digraph homomorphism›

lemma (in digraph) dg_dghm_id_is_dghm: "dghm_id ℭ : ℭ ↦↦DGα ℭ"
proof(intro is_dghmI, unfold dg_cs_simps)
  show "vfsequence (dghm_id ℭ)" unfolding dghm_id_def by simp
  show "vcard (dghm_id ℭ) = 4ℕ"
    unfolding dghm_id_def by (simp add: nat_omega_simps)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+

lemma (in digraph) dg_dghm_id_is_dghm': 
  assumes "𝔄 = ℭ" and "𝔅 = ℭ"
  shows "dghm_id ℭ : 𝔄 ↦↦DGα 𝔅"
  unfolding assms by (rule dg_dghm_id_is_dghm)

lemmas [dg_cs_intros] = digraph.dg_dghm_id_is_dghm'


subsubsection‹Further properties›

lemma (in is_dghm) dghm_dghm_comp_dghm_id_left: "dghm_id 𝔅 ∘DGHM 𝔉 = 𝔉"
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
proof(rule dghm_eqI [of α 𝔄 𝔅 _ 𝔄 𝔅])
  show "(dghm_id 𝔅 ∘DGHM 𝔉)⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
  proof(rule vsv_eqI)
    show "(dghm_id 𝔅 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((dghm_id 𝔅 ∘DGHM 𝔉)⦇ObjMap⦈)" for a 
      using that 
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
  show "(dghm_id 𝔅 ∘DGHM 𝔉)⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
  proof(rule vsv_eqI)
    show "(dghm_id 𝔅 ∘DGHM 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((dghm_id 𝔅 ∘DGHM 𝔉)⦇ArrMap⦈)" for a 
      using that 
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
qed (cs_concl cs_simp: cs_intro: dg_cs_intros)+

lemmas [dg_cs_simps] = is_dghm.dghm_dghm_comp_dghm_id_left

lemma (in is_dghm) dghm_dghm_comp_dghm_id_right: "𝔉 ∘DGHM dghm_id 𝔄 = 𝔉"
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
proof(rule dghm_eqI [of α 𝔄 𝔅 _ 𝔄 𝔅])
  show "(𝔉 ∘DGHM dghm_id 𝔄)⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
  proof(rule vsv_eqI)
    show "(𝔉 ∘DGHM dghm_id 𝔄)⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((𝔉 ∘DGHM dghm_id 𝔄)⦇ObjMap⦈)" for a 
      using that 
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
  show "(𝔉 ∘DGHM dghm_id 𝔄)⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
  proof(rule vsv_eqI)
    show "(𝔉 ∘DGHM dghm_id 𝔄)⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
      if "a ∈∘ 𝒟∘ ((𝔉 ∘DGHM dghm_id 𝔄)⦇ArrMap⦈)" for a 
      using that 
      by 
        (cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
        (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+

lemmas [dg_cs_simps] = is_dghm.dghm_dghm_comp_dghm_id_right



subsection‹Constant digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter III-3 in \cite{mac_lane_categories_2010}.›

definition dghm_const :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "dghm_const ℭ 𝔇 a f =
    [vconst_on (ℭ⦇Obj⦈) a, vconst_on (ℭ⦇Arr⦈) f, ℭ, 𝔇]∘"


text‹Components.›

lemma dghm_const_components:
  shows "dghm_const ℭ 𝔇 a f⦇ObjMap⦈ = vconst_on (ℭ⦇Obj⦈) a" 
    and "dghm_const ℭ 𝔇 a f⦇ArrMap⦈ = vconst_on (ℭ⦇Arr⦈) f" 
    and [dg_shared_cs_simps, dg_cs_simps]: "dghm_const ℭ 𝔇 a f⦇HomDom⦈ = ℭ"
    and [dg_shared_cs_simps, dg_cs_simps]: "dghm_const ℭ 𝔇 a f⦇HomCod⦈ = 𝔇" 
  unfolding dghm_const_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_const_components(1)[folded VLambda_vconst_on]
  |vsv dghm_const_ObjMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
  |vdomain dghm_const_ObjMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
  |app dghm_const_ObjMap_app[dg_shared_cs_simps, dg_cs_simps]|


subsubsection‹Arrow map›

mk_VLambda dghm_const_components(2)[folded VLambda_vconst_on]
  |vsv dghm_const_ArrMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
  |vdomain dghm_const_ArrMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
  |app dghm_const_ArrMap_app[dg_shared_cs_simps, dg_cs_simps]|


subsubsection‹Opposite constant digraph homomorphism›

lemma op_dghm_dghm_const[dg_op_simps]:
  "op_dghm (dghm_const ℭ 𝔇 a f) = dghm_const (op_dg ℭ) (op_dg 𝔇) a f"
  unfolding dghm_const_def op_dg_def op_dghm_def dghm_field_simps dg_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹A constant digraph homomorphism is a digraph homomorphism›

lemma dghm_const_is_dghm: 
  assumes "digraph α ℭ" and "digraph α 𝔇" and "f : a ↦𝔇 a"
  shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦DGα 𝔇"
proof-
  interpret 𝔇: digraph α 𝔇 by (rule assms(2))
  show ?thesis
  proof(intro is_dghmI)
    show "vfsequence (dghm_const ℭ 𝔇 a f)"
      unfolding dghm_const_def by simp
    show "vcard (dghm_const ℭ 𝔇 a f) = 4ℕ"
      unfolding dghm_const_def by (simp add: nat_omega_simps)
  qed 
    (
      use assms in 
        ‹
          cs_concl 
            cs_simp: dghm_const_components(1) dg_cs_simps
            cs_intro: V_cs_intros dg_cs_intros
        ›
    )+
qed

lemma dghm_const_is_dghm'[dg_cs_intros]: 
  assumes "digraph α ℭ" 
    and "digraph α 𝔇" 
    and "f : a ↦𝔇 a"
    and "𝔄 = ℭ"
    and "𝔅 = 𝔇"
  shows "dghm_const ℭ 𝔇 a f : 𝔄 ↦↦DGα 𝔅"
  using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_dghm)



subsection‹Faithful digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›

locale is_ft_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
  assumes ft_dghm_v11_on_Hom: 
    "⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"

syntax "_is_ft_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦DG.faithfulı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.faithfulα 𝔅" ⇌ "CONST is_ft_dghm α 𝔄 𝔅 𝔉"


text‹Rules.›

lemma (in is_ft_dghm) is_ft_dghm_axioms'[dghm_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.faithfulα' 𝔅'"
  unfolding assms by (rule is_ft_dghm_axioms)

mk_ide rf is_ft_dghm_def[unfolded is_ft_dghm_axioms_def]
  |intro is_ft_dghmI|
  |dest is_ft_dghmD[dest]|
  |elim is_ft_dghmE[elim]|

lemmas [dghm_cs_intros] = is_ft_dghmD(1)


subsubsection‹Opposite faithful digraph homomorphism›

lemma (in is_ft_dghm) ft_dghm_op_dghm_is_ft_dghm: 
  "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.faithfulα op_dg 𝔅"
  by 
    (
      rule is_ft_dghmI, 
      unfold dg_op_simps, 
      cs_concl cs_simp: cs_intro: dg_cs_intros dg_op_intros
    )
    (auto simp: ft_dghm_v11_on_Hom)

lemma (in is_ft_dghm) ft_dghm_op_dghm_is_ft_dghm'[dg_op_intros]: 
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DG.faithfulα 𝔅'"
  unfolding assms by (rule ft_dghm_op_dghm_is_ft_dghm)

lemmas ft_dghm_op_dghm_is_ft_dghm[dg_op_intros] = 
  is_ft_dghm.ft_dghm_op_dghm_is_ft_dghm'


subsubsection‹
The composition of faithful digraph homomorphisms is a faithful
digraph homomorphism.
›

lemma dghm_comp_is_ft_dghm[dghm_cs_intros]:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
  assumes "𝔊 : 𝔅 ↦↦DG.faithfulα ℭ" and "𝔉 : 𝔄 ↦↦DG.faithfulα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.faithfulα ℭ"
proof- 
  interpret L: is_ft_dghm α 𝔅 ℭ 𝔊 using assms(1) by auto
  interpret R: is_ft_dghm α 𝔄 𝔅 𝔉 using assms(2) by auto 
  have inj: 
    "⟦ a ∈∘ 𝔄⦇Obj⦈ ; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 ((𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"
    for a b
  proof-
    assume prems: "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔄⦇Obj⦈"
    then have 𝔊_hom_𝔅: 
      "v11 (𝔊⦇ArrMap⦈ ↾l∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈))" 
      by (intro L.ft_dghm_v11_on_Hom) 
        (cs_concl cs_intro: dg_cs_intros)+
    have "v11 (𝔊⦇ArrMap⦈ ↾l∘ (𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b))"
    proof(intro v11_vlrestriction_vsubset[OF 𝔊_hom_𝔅] vsubsetI)
      fix g assume "g ∈∘ 𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b" 
      then obtain f where f: "f : a ↦𝔄 b" and g_def: "g = 𝔉⦇ArrMap⦈⦇f⦈" 
        by auto
      from f show "g ∈∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
        by (cs_concl cs_simp: g_def cs_intro: dg_cs_intros)
    qed
    then show "v11 ((𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"
      unfolding dghm_comp_components
      by (intro v11_vlrestriction_vcomp) (auto simp: R.ft_dghm_v11_on_Hom prems)
  qed
  then show "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.faithfulα ℭ"
    by (intro is_ft_dghmI, cs_concl cs_intro: dg_cs_intros) auto
qed



subsection‹Full digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_fl_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
  assumes fl_dghm_surj_on_Hom: 
    "⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹
      𝔉⦇ArrMap⦈ `∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"

syntax "_is_fl_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦DG.fullı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.fullα 𝔅" ⇌ "CONST is_fl_dghm α 𝔄 𝔅 𝔉"


text‹Rules.›

lemma (in is_fl_dghm) is_fl_dghm_axioms'[dghm_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.fullα' 𝔅'"
  unfolding assms by (rule is_fl_dghm_axioms)

mk_ide rf is_fl_dghm_def[unfolded is_fl_dghm_axioms_def]
  |intro is_fl_dghmI|
  |dest is_fl_dghmD[dest]|
  |elim is_fl_dghmE[elim]|

lemmas [dghm_cs_intros] = is_fl_dghmD(1)


subsubsection‹Opposite full digraph homomorphism›

lemma (in is_fl_dghm) fl_dghm_op_dghm_is_fl_dghm:
  "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.fullα op_dg 𝔅"  
  by 
    (
      rule is_fl_dghmI,
      unfold dg_op_simps, 
      cs_concl cs_intro: dg_cs_intros dg_op_intros
    )
    (auto simp: fl_dghm_surj_on_Hom)

lemma (in is_fl_dghm) fl_dghm_op_dghm_is_fl_dghm'[dg_op_intros]:
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
  shows "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.fullα op_dg 𝔅"
  unfolding assms by (rule fl_dghm_op_dghm_is_fl_dghm)

lemmas fl_dghm_op_dghm_is_fl_dghm[dg_op_intros] = 
  is_fl_dghm.fl_dghm_op_dghm_is_fl_dghm'


subsubsection‹
The composition of full digraph homomorphisms is a full digraph homomorphism
›

lemma dghm_comp_is_fl_dghm[dghm_cs_intros]:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
  assumes "𝔊 : 𝔅 ↦↦DG.fullα ℭ" and "𝔉 : 𝔄 ↦↦DG.fullα 𝔅" 
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.fullα ℭ"
proof- 
  interpret L: is_fl_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
  interpret R: is_fl_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  have surj: 
    "⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ 
      (𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ `∘ (Hom 𝔄 a b) = 
        Hom ℭ ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈)"
    for a b
  proof-
    assume prems: "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔄⦇Obj⦈"
    have surj_𝔉: "𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)" 
      by (rule R.fl_dghm_surj_on_Hom[OF prems])
    from prems L.is_dghm_axioms R.is_dghm_axioms have comp_Obj:
      "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
      "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇b⦈⦈"
      by (auto simp: dg_cs_simps)
    have "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ `∘ Hom 𝔄 a b = 𝔊⦇ArrMap⦈ `∘ 𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b"
      unfolding dghm_comp_components by (simp add: vcomp_vimage)
    also from prems have 
      "… = Hom ℭ ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈)"
      unfolding surj_𝔉 comp_Obj
      by 
        (
          simp add: 
            prems(2) L.fl_dghm_surj_on_Hom R.dghm_ObjMap_app_in_HomCod_Obj
        )
    finally show "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ `∘ (Hom 𝔄 a b) =
      Hom ℭ ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈)"
      by simp
  qed
  show ?thesis  
    by (rule is_fl_dghmI, cs_concl cs_intro: dg_cs_intros)
      (auto simp: surj)
qed



subsection‹Fully faithful digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_ff_dghm = is_ft_dghm α 𝔄 𝔅 𝔉 + is_fl_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉

syntax "_is_ff_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦DG.ffı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.ffα 𝔅" ⇌ "CONST is_ff_dghm α 𝔄 𝔅 𝔉"


text‹Rules.›

lemma (in is_ff_dghm) is_ff_dghm_axioms'[dghm_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.ffα' 𝔅'"
  unfolding assms by (rule is_ff_dghm_axioms)

mk_ide rf is_ff_dghm_def
  |intro is_ff_dghmI|
  |dest is_ff_dghmD[dest]|
  |elim is_ff_dghmE[elim]|

lemmas [dghm_cs_intros] = is_ff_dghmD


subsubsection‹Opposite fully faithful digraph homomorphism.›

lemma (in is_ff_dghm) ff_dghm_op_dghm_is_ff_dghm: 
  "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.ffα op_dg 𝔅"  
  by (rule is_ff_dghmI) (cs_concl cs_intro: dg_op_intros)+

lemma (in is_ff_dghm) ff_dghm_op_dghm_is_ff_dghm'[dg_op_intros]: 
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DG.ffα 𝔅'" 
  unfolding assms by (rule ff_dghm_op_dghm_is_ff_dghm)

lemmas ff_dghm_op_dghm_is_ff_dghm[dg_op_intros] = 
  is_ff_dghm.ff_dghm_op_dghm_is_ff_dghm


subsubsection‹
The composition of fully faithful digraph homomorphisms is 
a fully faithful digraph homomorphism.
›

lemma dghm_comp_is_ff_dghm[dghm_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DG.ffα ℭ" and "𝔉 : 𝔄 ↦↦DG.ffα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.ffα ℭ"
  using assms 
  by (intro is_ff_dghmI, elim is_ff_dghmE) (cs_concl cs_intro: dghm_cs_intros)



subsection‹Isomorphism of digraphs›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_iso_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
  assumes iso_dghm_ObjMap_v11: "v11 (𝔉⦇ObjMap⦈)"
    and iso_dghm_ArrMap_v11: "v11 (𝔉⦇ArrMap⦈)"
    and iso_dghm_ObjMap_vrange[dghm_cs_simps]: "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
    and iso_dghm_ArrMap_vrange[dghm_cs_simps]: "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"

syntax "_is_iso_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦DG.isoı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.isoα 𝔅" ⇌ "CONST is_iso_dghm α 𝔄 𝔅 𝔉"

sublocale is_iso_dghm ⊆ ObjMap: v11 ‹𝔉⦇ObjMap⦈›
  rewrites "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈" and "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
  by (cs_concl cs_simp: dghm_cs_simps dg_cs_simps cs_intro: iso_dghm_ObjMap_v11)+

sublocale is_iso_dghm ⊆ ArrMap: v11 ‹𝔉⦇ArrMap⦈›
  rewrites "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈" and "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  by (cs_concl cs_simp: dghm_cs_simps dg_cs_simps cs_intro: iso_dghm_ArrMap_v11)+

lemmas [dghm_cs_simps] = 
  is_iso_dghm.iso_dghm_ObjMap_vrange
  is_iso_dghm.iso_dghm_ArrMap_vrange


text‹Rules.›

lemma (in is_iso_dghm) is_iso_dghm_axioms'[dghm_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.isoα' 𝔅'"
  unfolding assms by (rule is_iso_dghm_axioms)

mk_ide rf is_iso_dghm_def[unfolded is_iso_dghm_axioms_def]
  |intro is_iso_dghmI|
  |dest is_iso_dghmD[dest]|
  |elim is_iso_dghmE[elim]|


text‹Elementary properties.›

lemma (in is_iso_dghm) iso_dghm_Obj_HomDom_if_Obj_HomCod[elim]:
  assumes "b ∈∘ 𝔅⦇Obj⦈"
  obtains a where "a ∈∘ 𝔄⦇Obj⦈" and "b = 𝔉⦇ObjMap⦈⦇a⦈"
  using assms ObjMap.vrange_atD iso_dghm_ObjMap_vrange by blast

lemma (in is_iso_dghm) iso_dghm_Arr_HomDom_if_Arr_HomCod[elim]:
  assumes "g ∈∘ 𝔅⦇Arr⦈"
  obtains f where "f ∈∘ 𝔄⦇Arr⦈" and "g = 𝔉⦇ArrMap⦈⦇f⦈"
  using assms ArrMap.vrange_atD iso_dghm_ArrMap_vrange by blast

lemma (in is_iso_dghm) iso_dghm_ObjMap_eqE[elim]:
  assumes "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇b⦈" 
    and "a ∈∘ 𝔄⦇Obj⦈" 
    and "b ∈∘ 𝔄⦇Obj⦈" 
    and "a = b ⟹ P"
  shows P
  using assms ObjMap.v11_eq_iff by auto

lemma (in is_iso_dghm) iso_dghm_ArrMap_eqE[elim]:
  assumes "𝔉⦇ArrMap⦈⦇f⦈ = 𝔉⦇ArrMap⦈⦇g⦈"
    and "f ∈∘ 𝔄⦇Arr⦈"
    and "g ∈∘ 𝔄⦇Arr⦈"
    and "f = g ⟹ P"
  shows P
  using assms ArrMap.v11_eq_iff by auto

sublocale is_iso_dghm ⊆ is_ft_dghm 
  by (intro is_ft_dghmI, cs_concl cs_intro: dg_cs_intros) auto

sublocale is_iso_dghm ⊆ is_fl_dghm
proof
  fix a b assume [intro]: "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔄⦇Obj⦈" 
  show "𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
  proof(intro vsubset_antisym vsubsetI)
    fix g assume prems: "g ∈∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
    then have g: "g : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈" by auto
    then have dom_g: "𝔅⦇Dom⦈⦇g⦈ = 𝔉⦇ObjMap⦈⦇a⦈" 
      and cod_g: "𝔅⦇Cod⦈⦇g⦈ = 𝔉⦇ObjMap⦈⦇b⦈" 
      by blast+
    from prems obtain f 
      where [intro, simp]: "f ∈∘ 𝔄⦇Arr⦈" and g_def: "g = 𝔉⦇ArrMap⦈⦇f⦈" 
      by auto
    then obtain a' b' where f: "f : a' ↦𝔄 b'"  by blast
    then have "g : 𝔉⦇ObjMap⦈⦇a'⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b'⦈" 
      by (cs_concl cs_simp: g_def dg_cs_simps cs_intro: dg_cs_intros)
    with g have "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a'⦈" and "𝔉⦇ObjMap⦈⦇b⦈ = 𝔉⦇ObjMap⦈⦇b'⦈"
      by (metis HomCod.dg_is_arrE cod_g)+
    with f have "a = 𝔄⦇Dom⦈⦇f⦈" "b = 𝔄⦇Cod⦈⦇f⦈" by auto (*slow*)
    with f show "g ∈∘ 𝔉⦇ArrMap⦈ `∘ Hom 𝔄 a b"  
      by (auto simp: g_def HomDom.dg_is_arrD(4,5) ArrMap.vsv_vimageI1)
  qed (metis ArrMap.vsv_vimageE dghm_ArrMap_is_arr' in_Hom_iff)
qed

sublocale is_iso_dghm ⊆ is_ff_dghm by unfold_locales

lemmas (in is_iso_dghm) iso_dghm_is_ff_dghm = is_ff_dghm_axioms
lemmas [dghm_cs_intros] = is_iso_dghm.iso_dghm_is_ff_dghm


subsubsection‹Opposite digraph isomorphisms›

lemma (in is_iso_dghm) is_iso_dghm_op: 
  "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.isoα op_dg 𝔅"
  by (intro is_iso_dghmI, unfold dg_op_simps)
    (
      cs_concl 
        cs_simp: dghm_cs_simps cs_intro: V_cs_intros dg_cs_intros dg_op_intros
    )+

lemma (in is_iso_dghm) is_iso_dghm_op': 
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DG.isoα 𝔅'"
  unfolding assms by (rule is_iso_dghm_op)
  
lemmas is_iso_dghm_op[dg_op_intros] = is_iso_dghm.is_iso_dghm_op'


subsubsection‹
The composition of isomorphisms of digraphs is an isomorphism of digraphs
›
 
lemma dghm_comp_is_iso_dghm[dghm_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DG.isoα ℭ" and "𝔉 : 𝔄 ↦↦DG.isoα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.isoα ℭ"
proof- 
  interpret 𝔉: is_iso_dghm α 𝔄 𝔅 𝔉 using assms by auto
  interpret 𝔊: is_iso_dghm α 𝔅 ℭ 𝔊 using assms by auto
  show ?thesis
    by (intro is_iso_dghmI, unfold dghm_comp_components)
      (
        cs_concl 
          cs_simp: V_cs_simps dg_cs_simps dghm_cs_simps 
          cs_intro: dg_cs_intros V_cs_intros
      )+
qed


subsubsection‹An identity digraph homomorphism is an isomorphism of digraphs.›

lemma (in digraph) dg_dghm_id_is_iso_dghm: "dghm_id ℭ : ℭ ↦↦DG.isoα ℭ"
  by (rule is_iso_dghmI) (simp_all add: dg_dghm_id_is_dghm dghm_id_components)

lemma (in digraph) dg_dghm_id_is_iso_dghm'[dghm_cs_intros]:
  assumes "𝔄' = ℭ" and "𝔅' = ℭ"
  shows "dghm_id ℭ : 𝔄' ↦↦DG.isoα 𝔅'"
  unfolding assms by (rule dg_dghm_id_is_iso_dghm)

lemmas [dghm_cs_intros] = digraph.dg_dghm_id_is_iso_dghm'



subsection‹Inverse digraph homomorphism›


subsubsection‹Definition and elementary properties›

definition inv_dghm :: "V ⇒ V"
  where "inv_dghm 𝔉 = [(𝔉⦇ObjMap⦈)¯∘, (𝔉⦇ArrMap⦈)¯∘, 𝔉⦇HomCod⦈, 𝔉⦇HomDom⦈]∘"


text‹Components.›

lemma inv_dghm_components:
  shows "inv_dghm 𝔉⦇ObjMap⦈ = (𝔉⦇ObjMap⦈)¯∘" 
    and "inv_dghm 𝔉⦇ArrMap⦈ = (𝔉⦇ArrMap⦈)¯∘" 
    and [dghm_cs_simps]: "inv_dghm 𝔉⦇HomDom⦈ = 𝔉⦇HomCod⦈"
    and [dghm_cs_simps]: "inv_dghm 𝔉⦇HomCod⦈ = 𝔉⦇HomDom⦈" 
  unfolding inv_dghm_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

lemma (in is_iso_dghm) inv_dghm_ObjMap_v11[dghm_cs_intros]:
  "v11 (inv_dghm 𝔉⦇ObjMap⦈)"
  unfolding inv_dghm_components by (cs_concl cs_intro: V_cs_intros)

lemmas [dghm_cs_intros] = is_iso_dghm.inv_dghm_ObjMap_v11

lemma (in is_iso_dghm) inv_dghm_ObjMap_vdomain[dghm_cs_simps]:
  "𝒟∘ (inv_dghm 𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
  unfolding inv_dghm_components by (cs_concl cs_simp: dghm_cs_simps V_cs_simps)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_vdomain

lemma (in is_iso_dghm) inv_dghm_ObjMap_app[dghm_cs_simps]:
  assumes "a' = 𝔉⦇ObjMap⦈⦇a⦈" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "inv_dghm 𝔉⦇ObjMap⦈⦇a'⦈ = a" 
  unfolding inv_dghm_components
  by (metis assms ObjMap.vconverse_atI ObjMap.vsv_vconverse vsv.vsv_appI)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_app

lemma (in is_iso_dghm) inv_dghm_ObjMap_vrange[dghm_cs_simps]: 
  "ℛ∘ (inv_dghm 𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
  unfolding inv_dghm_components by (cs_concl cs_simp: dg_cs_simps V_cs_simps)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_vrange


subsubsection‹Arrow map›

lemma (in is_iso_dghm) inv_dghm_ArrMap_v11[dghm_cs_intros]:
  "v11 (inv_dghm 𝔉⦇ArrMap⦈)"
  unfolding inv_dghm_components by (cs_concl cs_intro: V_cs_intros)

lemmas [dghm_cs_intros] = is_iso_dghm.inv_dghm_ArrMap_v11

lemma (in is_iso_dghm) inv_dghm_ArrMap_vdomain[dghm_cs_simps]:
  "𝒟∘ (inv_dghm 𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  unfolding inv_dghm_components by (cs_concl cs_simp: dghm_cs_simps V_cs_simps)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_vdomain

lemma (in is_iso_dghm) inv_dghm_ArrMap_app[dghm_cs_simps]:
  assumes "a' = 𝔉⦇ArrMap⦈⦇a⦈" and "a ∈∘ 𝔄⦇Arr⦈"
  shows "inv_dghm 𝔉⦇ArrMap⦈⦇a'⦈ = a" 
  unfolding inv_dghm_components
  by (metis assms ArrMap.vconverse_atI ArrMap.vsv_vconverse vsv.vsv_appI)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_app

lemma (in is_iso_dghm) inv_dghm_ArrMap_vrange[dghm_cs_simps]: 
  "ℛ∘ (inv_dghm 𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
  unfolding inv_dghm_components by (cs_concl cs_simp: dg_cs_simps V_cs_simps)

lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_vrange


subsubsection‹Further properties›

lemma (in is_iso_dghm) iso_dghm_ObjMap_inv_dghm_ObjMap_app[dghm_cs_simps]: 
  assumes "a ∈∘ 𝔅⦇Obj⦈"
  shows "𝔉⦇ObjMap⦈⦇inv_dghm 𝔉⦇ObjMap⦈⦇a⦈⦈ = a"
  using assms by (cs_concl cs_simp: inv_dghm_components V_cs_simps)

lemmas [dghm_cs_simps] = is_iso_dghm.iso_dghm_ObjMap_inv_dghm_ObjMap_app

lemma (in is_iso_dghm) iso_dghm_ArrMap_inv_dghm_ArrMap_app[dghm_cs_simps]:
  assumes "f : a ↦𝔅 b"
  shows "𝔉⦇ArrMap⦈⦇inv_dghm 𝔉⦇ArrMap⦈⦇f⦈⦈ = f"
  using assms
  by (cs_concl cs_simp: inv_dghm_components V_cs_simps cs_intro: dg_cs_intros)

lemmas [dghm_cs_simps] = is_iso_dghm.iso_dghm_ArrMap_inv_dghm_ArrMap_app

lemma (in is_iso_dghm) iso_dghm_HomDom_is_arr_conv:
  assumes "f ∈∘ 𝔄⦇Arr⦈" 
    and "a ∈∘ 𝔄⦇Obj⦈" 
    and "b ∈∘ 𝔄⦇Obj⦈" 
    and "𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"
  shows "f : a ↦𝔄 b" 
  by 
    (
      metis 
        assms
        HomDom.dg_is_arrE 
        is_arr_def 
        dghm_ArrMap_is_arr 
        iso_dghm_ObjMap_eqE
    )

lemma (in is_iso_dghm) iso_dghm_HomCod_is_arr_conv:
  assumes "f ∈∘ 𝔅⦇Arr⦈" 
    and "a ∈∘ 𝔅⦇Obj⦈" 
    and "b ∈∘ 𝔅⦇Obj⦈" 
    and "inv_dghm 𝔉⦇ArrMap⦈⦇f⦈ : inv_dghm 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔄 inv_dghm 𝔉⦇ObjMap⦈⦇b⦈"
  shows "f : a ↦𝔅 b" 
  by 
    (
      metis 
        assms 
        dghm_ArrMap_is_arr' 
        is_arrI 
        iso_dghm_ArrMap_inv_dghm_ArrMap_app 
        iso_dghm_ObjMap_inv_dghm_ObjMap_app
    )



subsection‹An isomorphism of digraphs is an isomorphism in the category ‹GRPH››


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›

lemma is_arr_isomorphism_is_iso_dghm: 
  assumes "𝔉 : 𝔄 ↦↦DGα 𝔅"
    and "𝔊 : 𝔅 ↦↦DGα 𝔄"
    and "𝔊 ∘DGHM 𝔉 = dghm_id 𝔄"
    and "𝔉 ∘DGHM 𝔊 = dghm_id 𝔅"
  shows "𝔉 : 𝔄 ↦↦DG.isoα 𝔅"
proof(intro is_iso_dghmI)

  interpret L: is_dghm α 𝔅 𝔄 𝔊 by (rule assms(2))
  interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))

  show "𝔉 : 𝔄 ↦↦DGα 𝔅" by (cs_concl cs_intro: dg_cs_intros)

  show "v11 (𝔉⦇ObjMap⦈)" 
  proof(rule R.ObjMap.vsv_valeq_v11I)
    fix a b assume prems[simp]: 
      "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔄⦇Obj⦈" "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇b⦈"
    from assms(1,2) have "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ = (𝔊 ∘DGHM 𝔉)⦇ObjMap⦈⦇b⦈" 
      by (simp add: dg_cs_simps)
    then show "a = b" by (simp add: assms(3) dghm_id_components)
  qed

  show "v11 (𝔉⦇ArrMap⦈)"
  proof(rule R.ArrMap.vsv_valeq_v11I)
    fix a b 
    assume prems[simp]: 
      "a ∈∘ 𝔄⦇Arr⦈" "b ∈∘ 𝔄⦇Arr⦈" "𝔉⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇b⦈"
    then have "𝔉⦇ArrMap⦈⦇a⦈ ∈∘ 𝔅⦇Arr⦈" 
      by (cs_concl cs_intro: dg_cs_intros)
    with R.dghm_ArrMap_vsv L.dghm_ArrMap_vsv R.dghm_ArrMap_vrange have 
      "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇a⦈ = (𝔊 ∘DGHM 𝔉)⦇ArrMap⦈⦇b⦈" 
      unfolding dghm_comp_components by (simp add: dg_cs_simps)
    then show "a = b" by (simp add: assms(3) dghm_id_components)
  qed

  show "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
  proof(intro vsubset_antisym vsubsetI)
    from R.dghm_ObjMap_vrange show "a ∈∘ ℛ∘ (𝔉⦇ObjMap⦈) ⟹ a ∈∘ 𝔅⦇Obj⦈" for a
      by auto
  next
    fix a assume prems: "a ∈∘ 𝔅⦇Obj⦈" 
    then have a_def[symmetric]: "(𝔉 ∘DGHM 𝔊)⦇ObjMap⦈⦇a⦈ = a" 
      unfolding assms(4) dghm_id_components by simp
    from prems show "a ∈∘ ℛ∘ (𝔉⦇ObjMap⦈)"
      by (subst a_def)
        (cs_concl cs_intro: V_cs_intros dg_cs_intros cs_simp: dg_cs_simps)
  qed

  show "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  proof(intro vsubset_antisym vsubsetI)
    from R.dghm_ArrMap_vrange show "a ∈∘ ℛ∘ (𝔉⦇ArrMap⦈) ⟹ a ∈∘ 𝔅⦇Arr⦈" for a
      by auto
  next
    fix a assume prems: "a ∈∘ 𝔅⦇Arr⦈" 
    then have a_def[symmetric]: "(𝔉 ∘DGHM 𝔊)⦇ArrMap⦈⦇a⦈ = a" 
      unfolding assms(4) dghm_id_components by simp
    with prems show "a ∈∘ ℛ∘ (𝔉⦇ArrMap⦈)" 
      by (subst a_def)
        (cs_concl cs_intro: V_cs_intros dg_cs_intros cs_simp: dg_cs_simps)
  qed

qed

lemma is_iso_dghm_is_arr_isomorphism:
  assumes "𝔉 : 𝔄 ↦↦DG.isoα 𝔅"
  shows [dghm_cs_intros]: "inv_dghm 𝔉 : 𝔅 ↦↦DG.isoα 𝔄"
    and "inv_dghm 𝔉 ∘DGHM 𝔉 = dghm_id 𝔄"
    and "𝔉 ∘DGHM inv_dghm 𝔉 = dghm_id 𝔅"
proof-

  let ?𝔊 = ‹inv_dghm 𝔉›

  interpret is_iso_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))

  show 𝔊: "?𝔊 : 𝔅 ↦↦DG.isoα 𝔄"
  proof(intro is_iso_dghmI is_dghmI, unfold dghm_cs_simps)
    show "vfsequence (inv_dghm 𝔉)" unfolding inv_dghm_def by auto
    show "vcard (inv_dghm 𝔉) = 4ℕ"
      unfolding inv_dghm_def by (simp add: nat_omega_simps)
    show "inv_dghm 𝔉⦇ArrMap⦈⦇f⦈ : inv_dghm 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔄 inv_dghm 𝔉⦇ObjMap⦈⦇b⦈"
      if "f : a ↦𝔅 b" for a b f
      using that 
      by 
        (
          intro iso_dghm_HomDom_is_arr_conv, 
          use nothing in ‹unfold inv_dghm_components›
        )
        (
          cs_concl 
            cs_simp: V_cs_simps dghm_cs_simps dg_cs_simps 
            cs_intro: dg_cs_intros V_cs_intros 
        )+
  qed 
    (
      cs_concl 
        cs_simp: dg_cs_simps 
        cs_intro: dg_cs_intros V_cs_intros dghm_cs_intros
    )+

  show "inv_dghm 𝔉 ∘DGHM 𝔉 = dghm_id 𝔄"
  proof(rule dghm_eqI[of α 𝔄 𝔄 _ 𝔄 𝔄])
    show "(inv_dghm 𝔉 ∘DGHM 𝔉)⦇ObjMap⦈ = dghm_id 𝔄⦇ObjMap⦈"
      unfolding inv_dghm_components dghm_comp_components dghm_id_components
      by (rule ObjMap.v11_vcomp_vconverse)    
    show "(inv_dghm 𝔉 ∘DGHM 𝔉)⦇ArrMap⦈ = dghm_id 𝔄⦇ArrMap⦈"
      unfolding inv_dghm_components dghm_comp_components dghm_id_components
      by (rule ArrMap.v11_vcomp_vconverse)    
  qed (use 𝔊 in ‹cs_concl cs_intro: dghm_cs_intros›)

  show "𝔉 ∘DGHM inv_dghm 𝔉 = dghm_id 𝔅"
  proof(rule dghm_eqI[of α 𝔅 𝔅 _ 𝔅 𝔅])
    show "(𝔉 ∘DGHM inv_dghm 𝔉)⦇ObjMap⦈ = dghm_id 𝔅⦇ObjMap⦈"
      unfolding inv_dghm_components dghm_comp_components dghm_id_components
      by (rule ObjMap.v11_vcomp_vconverse')
    show "(𝔉 ∘DGHM inv_dghm 𝔉)⦇ArrMap⦈ = dghm_id 𝔅⦇ArrMap⦈"
      unfolding inv_dghm_components dghm_comp_components dghm_id_components
      by (rule ArrMap.v11_vcomp_vconverse')
  qed (use 𝔊 in ‹cs_concl cs_intro: dghm_cs_intros›)

qed



subsection‹Isomorphic digraphs›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›

locale iso_digraph = 
  fixes α 𝔄 𝔅 :: V
  assumes iso_digraph_is_iso_dghm: "∃𝔉. 𝔉 : 𝔄 ↦↦DG.isoα 𝔅"

notation iso_digraph (infixl "≈DGı" 50)

sublocale iso_digraph ⊆ HomDom: digraph α 𝔄 + HomCod: digraph α 𝔅
  using iso_digraph_is_iso_dghm by auto


text‹Rules.›

lemma iso_digraphI':
  assumes "∃𝔉. 𝔉 : 𝔄 ↦↦DG.isoα 𝔅" 
  shows "𝔄 ≈DGα 𝔅"
  using assms iso_digraph.intro by auto

lemma iso_digraphI:
  assumes "𝔉 : 𝔄 ↦↦DG.isoα 𝔅" 
  shows "𝔄 ≈DGα 𝔅"
  using assms unfolding iso_digraph_def by auto

lemma iso_digraphD[dest]:
  assumes "𝔄 ≈DGα 𝔅" 
  shows "∃𝔉. 𝔉 : 𝔄 ↦↦DG.isoα 𝔅" 
  using assms unfolding iso_digraph_def by simp_all

lemma iso_digraphE[elim]:
  assumes "𝔄 ≈DGα 𝔅" 
  obtains 𝔉 where "𝔉 : 𝔄 ↦↦DG.isoα 𝔅"
  using assms by auto


subsubsection‹A digraph isomorphism is an equivalence relation›

lemma iso_digraph_refl: 
  assumes "digraph α 𝔄" 
  shows "𝔄 ≈DGα 𝔄"
proof(rule iso_digraphI[of _ _ _ ‹dghm_id 𝔄›])
  interpret digraph α 𝔄 by (rule assms)
  show "dghm_id 𝔄 : 𝔄 ↦↦DG.isoα 𝔄" by (rule dg_dghm_id_is_iso_dghm)
qed

lemma iso_digraph_sym[sym]:
  assumes "𝔄 ≈DGα 𝔅" 
  shows "𝔅 ≈DGα 𝔄"
proof-
  interpret iso_digraph α 𝔄 𝔅 by (rule assms)
  from iso_digraph_is_iso_dghm obtain 𝔉 where "𝔉 : 𝔄 ↦↦DG.isoα 𝔅" 
    by clarsimp
  then have "inv_dghm 𝔉 : 𝔅 ↦↦DG.isoα 𝔄" 
    by (simp add: is_iso_dghm_is_arr_isomorphism(1))
  then show ?thesis by (cs_concl cs_intro: dghm_cs_intros iso_digraphI)
qed

lemma iso_digraph_trans[trans]:
  assumes "𝔄 ≈DGα 𝔅" and "𝔅 ≈DGα ℭ" 
  shows "𝔄 ≈DGα ℭ"
proof-
  interpret L: iso_digraph α 𝔄 𝔅 by (rule assms(1))
  interpret R: iso_digraph α 𝔅 ℭ by (rule assms(2))
  from L.iso_digraph_is_iso_dghm R.iso_digraph_is_iso_dghm show ?thesis 
    by (meson dghm_comp_is_iso_dghm iso_digraph.intro)
qed

text‹\newpage›

end

Theory CZH_DG_Small_DGHM

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for digraph homomorphisms›
theory CZH_DG_Small_DGHM
  imports 
    CZH_DG_Small_Digraph
    CZH_DG_DGHM
begin



subsection‹Digraph homomorphism with tiny maps›


subsubsection‹Definition and elementary properties›


text‹
The following construction is based on the concept
of a ‹small functor› used in \cite{shulman_set_2008}
in the context of the presentation of the set theory ‹ZFC/S›.
›

locale is_tm_dghm =
  is_dghm α 𝔄 𝔅 𝔉 +
  HomDom: digraph α 𝔄 + 
  HomCod: digraph α 𝔅
  for α 𝔄 𝔅 𝔉 +
  assumes tm_dghm_ObjMap_in_Vset[dg_small_cs_intros]: "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and tm_dghm_ArrMap_in_Vset[dg_small_cs_intros]: "𝔉⦇ArrMap⦈ ∈∘ Vset α"

syntax "_is_tm_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ ↦↦DG.tmı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.tmα 𝔅" ⇌ "CONST is_tm_dghm α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_tm_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_tm_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦DG.tmα 𝔅"

syntax "_is_cn_tm_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ DG.tm↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 DG.tm↦↦α 𝔅" ⇀ "CONST is_cn_tm_dghm α 𝔄 𝔅 𝔉"

abbreviation all_tm_dghms :: "V ⇒ V"
  where "all_tm_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tmα 𝔅}"

abbreviation small_tm_dghms :: "V ⇒ V ⇒ V ⇒ V"
  where "small_tm_dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦DG.tmα 𝔅}"

lemmas [dg_small_cs_intros] =
  is_tm_dghm.tm_dghm_ObjMap_in_Vset
  is_tm_dghm.tm_dghm_ArrMap_in_Vset


text‹Rules.›

lemma (in is_tm_dghm) is_tm_dghm_axioms'[dg_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.tmα' 𝔅'"
  unfolding assms by (rule is_tm_dghm_axioms)

mk_ide rf is_tm_dghm_def[unfolded is_tm_dghm_axioms_def]
  |intro is_tm_dghmI|
  |dest is_tm_dghmD[dest]|
  |elim is_tm_dghmE[elim]|

lemmas [dg_small_cs_intros] = is_tm_dghmD(1)


text‹Elementary properties.›

sublocale is_tm_dghm ⊆ HomDom: tiny_digraph α 𝔄 
proof(rule tiny_digraphI')
  show "𝔄⦇Obj⦈ ∈∘ Vset α"
    by (rule vdomain_in_VsetI[OF tm_dghm_ObjMap_in_Vset, simplified dg_cs_simps])
  show "𝔄⦇Arr⦈ ∈∘ Vset α"
    by (rule vdomain_in_VsetI[OF tm_dghm_ArrMap_in_Vset, simplified dg_cs_simps])
qed (cs_concl cs_intro: dg_cs_intros)

lemmas (in is_tm_dghm) 
  tm_dghm_HomDom_is_tiny_digraph = HomDom.tiny_digraph_axioms

lemmas [dg_small_cs_intros] = is_tm_dghm.tm_dghm_HomDom_is_tiny_digraph


text‹Further rules.›

lemma is_tm_dghmI':
  assumes "𝔉 : 𝔄 ↦↦DGα 𝔅"
    and [simp]: "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and [simp]: "𝔉⦇ArrMap⦈ ∈∘ Vset α"
  shows "𝔉 : 𝔄 ↦↦DG.tmα 𝔅"
proof-
  interpret is_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))
  from assms show ?thesis
    by (intro is_tm_dghmI) (auto simp: vfsequence_axioms dghm_ObjMap_vrange)
qed


text‹Size.›

lemma small_all_tm_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tmα 𝔅}"
proof(rule down)
  show 
    "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tmα 𝔅} ⊆
      elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_dghms if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tmα 𝔅"
    then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦DG.tmα 𝔅" by clarsimp
    interpret is_tm_dghm α 𝔄 𝔅 𝔉 by (rule 𝔉)
    from is_dghm_axioms' show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅" by blast
  qed
qed


subsubsection‹Opposite digraph homomorphism with tiny maps›

lemma (in is_tm_dghm) is_tm_dghm_op: "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.tmα op_dg 𝔅"
  by (intro is_tm_dghmI', unfold dg_op_simps)
    (cs_concl cs_intro: dg_cs_intros dg_small_cs_intros dg_op_intros)

lemma (in is_tm_dghm) is_tm_dghm_op'[dg_op_intros]:  
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DG.tmα' 𝔅'"
  unfolding assms by (rule is_tm_dghm_op)

lemmas is_tm_dghm_op[dg_op_intros] = is_tm_dghm.is_tm_dghm_op'


subsubsection‹Composition of a digraph homomorphism with tiny maps›

lemma dghm_comp_is_tm_dghm[dg_small_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DG.tmα ℭ" and "𝔉 : 𝔄 ↦↦DG.tmα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.tmα ℭ"
proof-
  interpret 𝔉: is_tm_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  interpret 𝔊: is_tm_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
  show ?thesis
  proof(intro is_tm_dghmI')
    from assms show "(𝔊 ∘DGHM 𝔉)⦇ObjMap⦈ ∈∘ Vset α"
      by 
        (
          cs_concl 
            cs_simp: dghm_comp_components 
            cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI 𝔉.Limit_α 
        )+
    from assms show "(𝔊 ∘DGHM 𝔉)⦇ArrMap⦈ ∈∘ Vset α"
      by 
        (
          cs_concl 
            cs_simp: dghm_comp_components 
            cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI 𝔉.Limit_α 
        )+
  qed (auto intro: dg_cs_intros)
qed


subsubsection‹Finite digraphs and digraph homomorphisms with tiny maps›

lemma (in is_dghm) dghm_is_tm_dghm_if_HomDom_finite_digraph:
  assumes "finite_digraph α 𝔄"
  shows "𝔉 : 𝔄 ↦↦DG.tmα 𝔅"
proof(intro is_tm_dghmI')
  interpret 𝔄: finite_digraph α 𝔄 by (rule assms(1))
  show "𝔉⦇ObjMap⦈ ∈∘ Vset α"
  proof(rule ObjMap.vsv_Limit_vsv_in_VsetI)
    show "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ Vset α"
    proof-
      have "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 𝔅⦇Obj⦈" by (simp add: dghm_ObjMap_vrange)
      moreover have "𝔅⦇Obj⦈ ⊆∘ Vset α"
        by (simp add: HomCod.dg_Obj_vsubset_Vset)
      ultimately show ?thesis by auto
    qed
  qed (auto simp: dg_cs_simps dg_small_cs_intros)
  show "𝔉⦇ArrMap⦈ ∈∘ Vset α"
  proof(rule ArrMap.vsv_Limit_vsv_in_VsetI)
    show "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ Vset α"
    proof-
      have "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ 𝔅⦇Arr⦈" by (simp add: dghm_ArrMap_vrange)
      moreover have "𝔅⦇Arr⦈ ⊆∘ Vset α"
        by (simp add: HomCod.dg_Arr_vsubset_Vset)
      ultimately show ?thesis by auto
    qed
  qed (auto simp: dg_cs_simps dg_small_cs_intros)
qed (simp add: dg_cs_intros)


subsubsection‹Constant digraph homomorphism›

lemma dghm_const_is_tm_dghm: 
  assumes "tiny_digraph α ℭ" and "digraph α 𝔇" and "f : a ↦𝔇 a"
  shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦DG.tmα 𝔇"
proof(intro is_tm_dghmI')
  interpret ℭ: tiny_digraph α ℭ by (rule assms(1))
  interpret 𝔇: digraph α 𝔇 by (rule assms(2))
  from assms show "dghm_const ℭ 𝔇 a f : ℭ ↦↦DGα 𝔇"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "dghm_const ℭ 𝔇 a f⦇ObjMap⦈ ∈∘ Vset α"
    unfolding dghm_const_components
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    from assms(3) have "a ∈∘ set {a}" by (cs_concl  cs_intro: V_cs_intros)
    with assms(3) show "ℛ∘ (vconst_on (ℭ⦇Obj⦈) a) ∈∘ Vset α"
      by 
        (
          cs_concl cs_intro: 
            dg_cs_intros 
            V_cs_intros
            𝔇.dg_in_Obj_in_Vset 
            vsubset_in_VsetI 
            Limit_vsingleton_in_VsetI 
        )
    show "𝒟∘ (vconst_on (ℭ⦇Obj⦈) a) ∈∘ Vset α"
      by (cs_concl cs_simp: V_cs_simps cs_intro: V_cs_intros dg_small_cs_intros)
  qed simp_all
  show "dghm_const ℭ 𝔇 a f⦇ArrMap⦈ ∈∘ Vset α"
    unfolding dghm_const_components
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    from assms(3) 𝔇.dg_Arr_vsubset_Vset show
      "ℛ∘ (vconst_on (ℭ⦇Arr⦈) f) ∈∘ Vset α"
      by (cases ‹ℭ⦇Arr⦈=0›)
        (
          auto 
            simp: dg_cs_simps 𝔇.dg_is_arrD(1) 
            intro!: Limit_vsingleton_in_VsetI
        ) 
  qed (auto simp: ℭ.tiny_dg_Arr_in_Vset)
qed

lemma dghm_const_is_tm_dghm'[dg_small_cs_intros]:
  assumes "tiny_digraph α ℭ"
    and "digraph α 𝔇" 
    and "f : a ↦𝔇 a"
    and "ℭ' = ℭ"
    and "𝔇' = 𝔇"
  shows "dghm_const ℭ 𝔇 a f : ℭ' ↦↦DG.tmα 𝔇'"
  using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tm_dghm)



subsection‹Tiny digraph homomorphism›


subsubsection‹Definition and elementary properties›

locale is_tiny_dghm = 
  is_dghm α 𝔄 𝔅 𝔉 +
  HomDom: tiny_digraph α 𝔄 + 
  HomCod: tiny_digraph α 𝔅 
  for α 𝔄 𝔅 𝔉

syntax "_is_tiny_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ ↦↦DG.tinyı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦DG.tinyα 𝔅" ⇌ "CONST is_tiny_dghm α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_tiny_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_tiny_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦DG.tinyα 𝔅"

syntax "_is_cn_tiny_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ DG.tiny↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 DG.tiny↦↦α 𝔅" ⇀ "CONST is_cn_tiny_dghm α 𝔄 𝔅 𝔉"

abbreviation all_tiny_dghms :: "V ⇒ V"
  where "all_tiny_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅}"

abbreviation small_dghms :: "V ⇒ V ⇒ V ⇒ V"
  where "small_dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅}"


text‹Rules.›

lemma (in is_tiny_dghm) is_tiny_dghm_axioms'[dg_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦DG.tinyα' 𝔅'"
  unfolding assms by (rule is_tiny_dghm_axioms)

mk_ide rf is_tiny_dghm_def
  |intro is_tiny_dghmI|
  |dest is_tiny_dghmD[dest]|
  |elim is_tiny_dghmE[elim]|

lemmas [dg_small_cs_intros] = is_tiny_dghmD(2,3)


text‹Size.›

lemma (in is_tiny_dghm) tiny_dghm_ObjMap_in_Vset[dg_small_cs_intros]: 
  "𝔉⦇ObjMap⦈ ∈∘ Vset α"
proof-
  have "𝒟∘ (𝔉⦇ObjMap⦈) ∈∘ Vset α" 
    by (simp add: dghm_ObjMap_vdomain HomDom.tiny_dg_Obj_in_Vset)
  moreover from dghm_ObjMap_vrange have "ℛ∘ (𝔉⦇ObjMap⦈) ∈∘ Vset α"
    by (simp add: vsubset_in_VsetI HomCod.tiny_dg_Obj_in_Vset)
  ultimately show "𝔉⦇ObjMap⦈ ∈∘ Vset α" 
    by 
      (
        cs_concl cs_intro: 
          V_cs_intros dg_small_cs_intros ObjMap.vbrelation_Limit_in_VsetI 
      )
qed

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ObjMap_in_Vset

lemma (in is_tiny_dghm) tiny_dghm_ArrMap_in_Vset[dg_small_cs_intros]: 
  "𝔉⦇ArrMap⦈ ∈∘ Vset α"
proof-
  have "𝒟∘ (𝔉⦇ArrMap⦈) ∈∘ Vset α"
    by (simp add: dghm_ArrMap_vdomain HomDom.tiny_dg_Arr_in_Vset)
  moreover from HomCod.tiny_dg_Arr_in_Vset dghm_ArrMap_vrange have 
    "ℛ∘ (𝔉⦇ArrMap⦈) ∈∘ Vset α"
    by auto
  ultimately show "𝔉⦇ArrMap⦈ ∈∘ Vset α" 
    by 
      (
        cs_concl cs_intro:  
          V_cs_intros dg_small_cs_intros ArrMap.vbrelation_Limit_in_VsetI
      )
qed

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ArrMap_in_Vset

lemma (in is_tiny_dghm) tiny_dghm_in_Vset: "𝔉 ∈∘ Vset α"
proof-
  note [dg_cs_intros] = 
    tiny_dghm_ObjMap_in_Vset 
    tiny_dghm_ArrMap_in_Vset
    HomDom.tiny_dg_in_Vset 
    HomCod.tiny_dg_in_Vset 
  show ?thesis
    by (subst dghm_def) 
      (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed

sublocale is_tiny_dghm ⊆ is_tm_dghm
  by (intro is_tm_dghmI') (auto simp: dg_cs_intros dg_small_cs_intros)

lemmas (in is_tiny_dghm) tiny_dghm_is_tm_dghm = is_tm_dghm_axioms

lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_is_tm_dghm

lemma small_all_tiny_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅}"
proof(rule down)
  show 
    "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅} ⊆
      elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_dghms if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅"
    then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦DG.tinyα 𝔅" by clarsimp
    interpret is_tiny_dghm α 𝔄 𝔅 𝔉 by (rule 𝔉)
    from is_dghm_axioms show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DGα 𝔅" by auto
  qed
qed

lemma tiny_dghms_vsubset_Vset[simp]: 
  "set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦DG.tinyα 𝔅} ⊆∘ Vset α"
proof(rule vsubsetI) 
  fix 𝔉 assume "𝔉 ∈∘ all_tiny_dghms α"
  then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦DG.tinyα 𝔅" by clarsimp
  then show "𝔉 ∈∘ Vset α" by (auto simp: is_tiny_dghm.tiny_dghm_in_Vset)
qed

lemma (in is_dghm) dghm_is_tiny_dghm_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 : 𝔄 ↦↦DG.tinyβ 𝔅"
proof(intro is_tiny_dghmI)
  interpret β: 𝒵 β by (rule assms(1))
  show "𝔉 : 𝔄 ↦↦DGβ 𝔅"
    by (intro dghm_is_dghm_if_ge_Limit)
      (use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
  show "tiny_digraph β 𝔄" "tiny_digraph β 𝔅"
    by 
      (
        simp_all add: 
          assms 
          HomDom.dg_tiny_digraph_if_ge_Limit 
          HomCod.dg_tiny_digraph_if_ge_Limit
      )
qed


subsubsection‹Opposite tiny digraph homomorphism›

lemma (in is_tiny_dghm) is_tiny_dghm_op: 
  "op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.tinyα op_dg 𝔅"
  by (intro is_tiny_dghmI) 
    (cs_concl cs_intro: dg_small_cs_intros dg_cs_intros dg_op_intros)+

lemma (in is_tiny_dghm) is_tiny_dghm_op'[dg_op_intros]:  
  assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
  shows "op_dghm 𝔉 : 𝔄' ↦↦DG.tinyα' 𝔅'"
  unfolding assms by (rule is_tiny_dghm_op)

lemmas is_tiny_dghm_op[dg_op_intros] = is_tiny_dghm.is_tiny_dghm_op'


subsubsection‹Composition of tiny digraph homomorphisms›

lemma dghm_comp_is_tiny_dghm[dg_small_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦DG.tinyα ℭ" and "𝔉 : 𝔄 ↦↦DG.tinyα 𝔅"
  shows "𝔊 ∘DGHM 𝔉 : 𝔄 ↦↦DG.tinyα ℭ"
proof-
  interpret 𝔉: is_tiny_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
  interpret 𝔊: is_tiny_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
  show ?thesis 
    by (intro is_tiny_dghmI) 
      (auto simp: dg_small_cs_intros dg_cs_simps intro: dg_cs_intros)
qed


subsubsection‹Tiny constant digraph homomorphism›

lemma dghm_const_is_tiny_dghm:
  assumes "tiny_digraph α ℭ" and "tiny_digraph α 𝔇" and "f : a ↦𝔇 a"
  shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦DG.tinyα 𝔇"
proof(intro is_tiny_dghmI)
  from assms show "dghm_const ℭ 𝔇 a f : ℭ ↦↦DGα 𝔇"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros)
qed (auto simp: assms(1,2))

lemma dghm_const_is_tiny_dghm'[dg_small_cs_intros]:
  assumes "tiny_digraph α ℭ"
    and "tiny_digraph α 𝔇" 
    and "f : a ↦𝔇 a"
    and "ℭ' = ℭ"
    and "𝔇' = 𝔇"
  shows "dghm_const ℭ 𝔇 a f : ℭ' ↦↦DG.tinyα 𝔇'"
  using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tiny_dghm)

text‹\newpage›

end

Theory CZH_DG_TDGHM

(* Copyright 2021 (C) Mihails Milehins *)

section‹Transformation of digraph homomorphisms›
theory CZH_DG_TDGHM
  imports CZH_DG_DGHM
begin



subsection‹Background›

named_theorems tdghm_cs_simps
named_theorems tdghm_cs_intros
named_theorems nt_field_simps

definition NTMap :: V where [nt_field_simps]: "NTMap = 0"
definition NTDom :: V where [nt_field_simps]: "NTDom = 1ℕ"
definition NTCod :: V where [nt_field_simps]: "NTCod = 2ℕ"
definition NTDGDom :: V where [nt_field_simps]: "NTDGDom = 3ℕ"
definition NTDGCod :: V where [nt_field_simps]: "NTDGCod = 4ℕ"



subsection‹Definition and elementary properties›


text‹
A transformation of digraph homomorphisms, as presented in this work, 
is a generalization of the concept of a natural transformation, as presented in
Chapter I-4 in \cite{mac_lane_categories_2010}, to digraphs and digraph
homomorphisms. The generalization is performed by excluding the commutativity 
axiom from the definition. 

The definition of a transformation of digraph homomorphisms is 
parameterized by a limit ordinal ‹α› such that ‹ω < α›. 
Such transformations of digraph homomorphisms are referred to either as
‹α›-transformations of digraph homomorphisms or 
transformations of ‹α›-digraph homomorphisms.
›

locale is_tdghm = 
  𝒵 α + 
  vfsequence 𝔑 + 
  NTDom: is_dghm α 𝔄 𝔅 𝔉 +
  NTCod: is_dghm α 𝔄 𝔅 𝔊 
  for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
  assumes tdghm_length[dg_cs_simps]: "vcard 𝔑 = 5ℕ"
    and tdghm_NTMap_vsv: "vsv (𝔑⦇NTMap⦈)"
    and tdghm_NTMap_vdomain[dg_cs_simps]: "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
    and tdghm_NTDom[dg_cs_simps]: "𝔑⦇NTDom⦈ = 𝔉"
    and tdghm_NTCod[dg_cs_simps]: "𝔑⦇NTCod⦈ = 𝔊"
    and tdghm_NTDGDom[dg_cs_simps]: "𝔑⦇NTDGDom⦈ = 𝔄"
    and tdghm_NTDGCod[dg_cs_simps]: "𝔑⦇NTDGCod⦈ = 𝔅"
    and tdghm_NTMap_is_arr: 
      "a ∈∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈"

syntax "_is_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦DGHM _ :/ _ ↦↦DGı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" ⇌
  "CONST is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_tdghms :: "V ⇒ V"
  where "all_tdghms α ≡ set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"

abbreviation tdghms :: "V ⇒ V ⇒ V ⇒ V"
  where "tdghms α 𝔄 𝔅 ≡ set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"

abbreviation these_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡ set {𝔑. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"

sublocale is_tdghm ⊆ NTMap: vsv ‹𝔑⦇NTMap⦈›
  rewrites "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
  by (rule tdghm_NTMap_vsv) (simp add: dg_cs_simps)

lemmas [dg_cs_simps] =  
  is_tdghm.tdghm_length
  is_tdghm.tdghm_NTMap_vdomain
  is_tdghm.tdghm_NTDom
  is_tdghm.tdghm_NTCod
  is_tdghm.tdghm_NTDGDom
  is_tdghm.tdghm_NTDGCod

lemma (in is_tdghm) tdghm_NTMap_is_arr'[dg_cs_intros]:
  assumes "a ∈∘ 𝔄⦇Obj⦈"
    and "A = 𝔉⦇ObjMap⦈⦇a⦈"
    and "B = 𝔊⦇ObjMap⦈⦇a⦈"
  shows "𝔑⦇NTMap⦈⦇a⦈ : A ↦𝔅 B"
  using assms(1) unfolding assms(2,3) by (rule tdghm_NTMap_is_arr)

lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_is_arr'


text‹Rules.›

lemma (in is_tdghm) is_tdghm_axioms'[dg_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "𝔑 : 𝔉' ↦DGHM 𝔊' : 𝔄' ↦↦DGα' 𝔅'"
  unfolding assms by (rule is_tdghm_axioms)

mk_ide rf is_tdghm_def[unfolded is_tdghm_axioms_def]
  |intro is_tdghmI|
  |dest is_tdghmD[dest]|
  |elim is_tdghmE[elim]|

lemmas [dg_cs_intros] =
  is_tdghmD(3,4)


text‹Elementary properties.›

lemma tdghm_eqI:
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" 
    and "𝔑' : 𝔉' ↦DGHM 𝔊' : 𝔄' ↦↦DGα 𝔅'"
    and "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
    and "𝔉 = 𝔉'"
    and "𝔊 = 𝔊'"
    and "𝔄 = 𝔄'"
    and "𝔅 = 𝔅'"
  shows "𝔑 = 𝔑'"
proof-
  interpret L: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret R: is_tdghm α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ 𝔑 = 5ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
    show "𝒟∘ 𝔑 = 𝒟∘ 𝔑'" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
    from assms(4-7) have sup: 
      "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈" 
      "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈" 
      by (simp_all add: dg_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔑 ⟹ 𝔑⦇a⦈ = 𝔑'⦇a⦈" for a 
      by (unfold dom, elim_in_numeral, insert assms(3) sup)
        (auto simp: nt_field_simps)
  qed (auto simp: L.vsv_axioms R.vsv_axioms)
qed

lemma (in is_tdghm) tdghm_def:
  "𝔑 = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ 𝔑 = 5ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
  have dom_rhs:
    "𝒟∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈]∘ = 5ℕ"
    by (simp add: nat_omega_simps)
  then show 
    "𝒟∘ 𝔑 = 𝒟∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘"
    unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
  show "a ∈∘ 𝒟∘ 𝔑 ⟹
    𝔑⦇a⦈ = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘⦇a⦈" 
    for a
    by (unfold dom_lhs, elim_in_numeral, unfold nt_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in is_tdghm) tdghm_NTMap_app_in_Arr[dg_cs_intros]:
  assumes "a ∈∘ 𝔄⦇Obj⦈"
  shows "𝔑⦇NTMap⦈⦇a⦈ ∈∘ 𝔅⦇Arr⦈"
  using assms using tdghm_NTMap_is_arr by auto

lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_app_in_Arr

lemma (in is_tdghm) tdghm_NTMap_vrange_vifunion:
  "ℛ∘ (𝔑⦇NTMap⦈) ⊆∘ (⋃∘a∈∘ℛ∘ (𝔉⦇ObjMap⦈). ⋃∘b∈∘ℛ∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
proof(intro NTMap.vsv_vrange_vsubset)
  fix x assume prems: "x ∈∘ 𝔄⦇Obj⦈"
  note 𝔑x = tdghm_NTMap_is_arr[OF prems]
  from prems show 
    "𝔑⦇NTMap⦈⦇x⦈ ∈∘ (⋃∘a∈∘ℛ∘ (𝔉⦇ObjMap⦈). ⋃∘b∈∘ℛ∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
    by (intro vifunionI, unfold in_Hom_iff) 
      (
        auto intro: 
          dg_cs_intros NTDom.ObjMap.vsv_vimageI2' NTCod.ObjMap.vsv_vimageI2' 
      )
qed

lemma (in is_tdghm) tdghm_NTMap_vrange: "ℛ∘ (𝔑⦇NTMap⦈) ⊆∘ 𝔅⦇Arr⦈"
proof(intro NTMap.vsv_vrange_vsubset)
  fix x assume "x ∈∘ 𝔄⦇Obj⦈"
  with is_tdghm_axioms show "𝔑⦇NTMap⦈⦇x⦈ ∈∘ 𝔅⦇Arr⦈"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed


text‹Size.›

lemma (in is_tdghm) tdghm_NTMap_vsubset_Vset: "𝔑⦇NTMap⦈ ⊆∘ Vset α"
proof(intro NTMap.vbrelation_Limit_vsubset_VsetI)
  show "ℛ∘ (𝔑⦇NTMap⦈) ⊆∘ Vset α"
    by 
      (
        rule vsubset_transitive, 
        rule tdghm_NTMap_vrange,
        rule NTDom.HomCod.dg_Arr_vsubset_Vset
      )
qed (simp_all add: NTDom.HomDom.dg_Obj_vsubset_Vset)

lemma (in is_tdghm) tdghm_NTMap_in_Vset: 
  assumes "α ∈∘ β"
  shows "𝔑⦇NTMap⦈ ∈∘ Vset β"
  by (meson assms tdghm_NTMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)

lemma (in is_tdghm) tdghm_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [dg_cs_intros] = 
    tdghm_NTMap_in_Vset
    NTDom.dghm_in_Vset
    NTCod.dghm_in_Vset
    NTDom.HomDom.dg_in_Vset
    NTDom.HomCod.dg_in_Vset
  from assms(2) show ?thesis
    by (subst tdghm_def) 
      (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed

lemma (in is_tdghm) tdghm_is_tdghm_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGβ 𝔅"
proof(rule is_tdghmI)
  show "𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈" if "a ∈∘ 𝔄⦇Obj⦈" for a
    using that by (cs_concl cs_intro: dg_cs_intros)
qed 
  (
    cs_concl 
      cs_simp: dg_cs_simps 
      cs_intro:
        V_cs_intros
        assms 
        NTDom.dghm_is_dghm_if_ge_Limit 
        NTCod.dghm_is_dghm_if_ge_Limit  
   )+

lemma small_all_tdghms[simp]: 
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"
proof(cases ‹𝒵 α›)
  case True
  from is_tdghm.tdghm_in_Vset show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›]) 
      (auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅} = {}" by auto
  then show ?thesis by simp
qed

lemma small_tdghms[simp]: "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"
  by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}›])
    auto

lemma small_these_tdghms[simp]: "small {𝔑. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}"
  by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅}›]) 
    auto


text‹Further elementary results.›

lemma these_tdghms_iff(*not simp*): 
  "𝔑 ∈∘ these_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷ 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
  by auto



subsection‹Opposite transformation of digraph homomorphisms›


subsubsection‹Definition and elementary properties›


text‹See section 1.5 in \cite{bodo_categories_1970}.›

definition op_tdghm :: "V ⇒ V"
  where "op_tdghm 𝔑 =
    [
      𝔑⦇NTMap⦈,
      op_dghm (𝔑⦇NTCod⦈),
      op_dghm (𝔑⦇NTDom⦈),
      op_dg (𝔑⦇NTDGDom⦈),
      op_dg (𝔑⦇NTDGCod⦈)
    ]∘"


text‹Components.›

lemma op_tdghm_components[dg_op_simps]:
  shows "op_tdghm 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
    and "op_tdghm 𝔑⦇NTDom⦈ = op_dghm (𝔑⦇NTCod⦈)"
    and "op_tdghm 𝔑⦇NTCod⦈ = op_dghm (𝔑⦇NTDom⦈)"
    and "op_tdghm 𝔑⦇NTDGDom⦈ = op_dg (𝔑⦇NTDGDom⦈)"
    and "op_tdghm 𝔑⦇NTDGCod⦈ = op_dg (𝔑⦇NTDGCod⦈)"
  unfolding op_tdghm_def nt_field_simps by (auto simp: nat_omega_simps)


subsubsection‹Further properties›

lemma (in is_tdghm) is_tdghm_op: 
  "op_tdghm 𝔑 : op_dghm 𝔊 ↦DGHM op_dghm 𝔉 : op_dg 𝔄 ↦↦DGα op_dg 𝔅"
proof(rule is_tdghmI, unfold dg_op_simps)
  show "vfsequence (op_tdghm 𝔑)" by (simp add: op_tdghm_def)
  show "vcard (op_tdghm 𝔑) = 5ℕ" by (simp add: op_tdghm_def nat_omega_simps)
  show "𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈" if "a ∈∘ 𝔄⦇Obj⦈" for a
    using that by (cs_concl cs_intro: dg_cs_intros)
qed 
  (
    cs_concl 
      cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_op_intros V_cs_intros
  )+

lemma (in is_tdghm) is_tdghm_op'[dg_op_intros]: 
  assumes "𝔊' = op_dghm 𝔊"
    and "𝔉' = op_dghm 𝔉"
    and "𝔄' = op_dg 𝔄"
    and "𝔅' = op_dg 𝔅"
  shows "op_tdghm 𝔑 : 𝔊' ↦DGHM 𝔉' : 𝔄' ↦↦DGα 𝔅'"
  unfolding assms by (rule is_tdghm_op)

lemmas is_tdghm_op[dg_op_intros] = is_tdghm.is_tdghm_op'

lemma (in is_tdghm) tdghm_op_tdghm_op_tdghm[dg_op_simps]: 
  "op_tdghm (op_tdghm 𝔑) = 𝔑"
proof(rule tdghm_eqI[of α 𝔄 𝔅 𝔉 𝔊 _ 𝔄 𝔅 𝔉 𝔊], unfold dg_op_simps)
  interpret op: 
    is_tdghm α ‹op_dg 𝔄› ‹op_dg 𝔅› ‹op_dghm 𝔊› ‹op_dghm 𝔉› ‹op_tdghm 𝔑›
    by (rule is_tdghm_op)
  from op.is_tdghm_op show 
    "op_tdghm (op_tdghm 𝔑) : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    by (simp add: dg_op_simps)
qed (auto simp: dg_cs_intros)

lemmas tdghm_op_tdghm_op_tdghm[dg_op_simps] = 
  is_tdghm.tdghm_op_tdghm_op_tdghm

lemma eq_op_tdghm_iff: 
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" 
    and "𝔑' : 𝔉' ↦DGHM 𝔊' : 𝔄' ↦↦DGα 𝔅'"
  shows "op_tdghm 𝔑 = op_tdghm 𝔑' ⟷ 𝔑 = 𝔑'"
proof
  interpret L: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret R: is_tdghm α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
  assume prems: "op_tdghm 𝔑 = op_tdghm 𝔑'"
  show "𝔑 = 𝔑'"
  proof(rule tdghm_eqI[OF assms])
    from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm show 
      "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
      by metis+
    from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm 
    have "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" 
      and "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈" 
      and "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" 
      and "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈" 
      by metis+
    then show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by (auto simp: dg_cs_simps)
  qed
qed auto



subsection‹
Composition of a transformation of digraph homomorphisms 
and a digraph homomorphism
›


subsubsection‹Definition and elementary properties›

definition tdghm_dghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘TDGHM-DGHM› 55)
  where "𝔑 ∘TDGHM-DGHM ℌ =
    [
      (λa∈∘ℌ⦇HomDom⦈⦇Obj⦈. 𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇a⦈⦈),
      𝔑⦇NTDom⦈ ∘DGHM ℌ,
      𝔑⦇NTCod⦈ ∘DGHM ℌ,
      ℌ⦇HomDom⦈,
      𝔑⦇NTDGCod⦈
    ]∘"


text‹Components.›

lemma tdghm_dghm_comp_components:
  shows "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTMap⦈ =
    (λa∈∘ℌ⦇HomDom⦈⦇Obj⦈. 𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇a⦈⦈)"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTDom⦈ = 𝔑⦇NTDom⦈ ∘DGHM ℌ"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTCod⦈ = 𝔑⦇NTCod⦈ ∘DGHM ℌ"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTDGDom⦈ = ℌ⦇HomDom⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTDGCod⦈ = 𝔑⦇NTDGCod⦈"
  unfolding tdghm_dghm_comp_def nt_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Transformation map›

mk_VLambda tdghm_dghm_comp_components(1)
  |vsv tdghm_dghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|

mk_VLambda (in is_dghm) 
  tdghm_dghm_comp_components(1)[where ℌ=𝔉, unfolded dghm_HomDom]
  |vdomain tdghm_dghm_comp_NTMap_vdomain|
  |app tdghm_dghm_comp_NTMap_app|

lemmas [dg_cs_simps] = 
  is_dghm.tdghm_dghm_comp_NTMap_vdomain
  is_dghm.tdghm_dghm_comp_NTMap_app

lemma tdghm_dghm_comp_NTMap_vrange: 
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔅 ↦↦DGα ℭ" and "ℌ : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((𝔑 ∘TDGHM-DGHM ℌ)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
  show ?thesis 
    unfolding tdghm_dghm_comp_components
  proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
    fix x assume "x ∈∘ 𝔄⦇Obj⦈"
    then show "𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇x⦈⦈ ∈∘ ℭ⦇Arr⦈"
      by (cs_concl cs_intro: dg_cs_intros)
  qed
qed


subsubsection‹
Opposite of the composition of a transformation of 
digraph homomorphisms and a digraph homomorphism
›

lemma op_tdghm_tdghm_dghm_comp[dg_op_simps]: 
  "op_tdghm (𝔑 ∘TDGHM-DGHM ℌ) = op_tdghm 𝔑 ∘TDGHM-DGHM op_dghm ℌ"
  unfolding 
    tdghm_dghm_comp_def 
    dghm_comp_def 
    op_tdghm_def 
    op_dghm_def 
    op_dg_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹
Composition of a transformation of digraph homomorphisms and a digraph
homomorphism is a transformation of digraph homomorphisms
›

lemma tdghm_dghm_comp_is_tdghm:
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔅 ↦↦DGα ℭ" and "ℌ : 𝔄 ↦↦DGα 𝔅"
  shows "𝔑 ∘TDGHM-DGHM ℌ : 𝔉 ∘DGHM ℌ ↦DGHM 𝔊 ∘DGHM ℌ : 𝔄 ↦↦DGα ℭ"
proof-
  interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
  show ?thesis
  proof(rule is_tdghmI)
    show "vfsequence (𝔑 ∘TDGHM-DGHM ℌ)" unfolding tdghm_dghm_comp_def by simp
    show "vcard (𝔑 ∘TDGHM-DGHM ℌ) = 5ℕ"
      unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
    show "(𝔑 ∘TDGHM-DGHM ℌ)⦇NTMap⦈⦇a⦈ :
      (𝔉 ∘DGHM ℌ)⦇ObjMap⦈⦇a⦈ ↦ℭ (𝔊 ∘DGHM ℌ)⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝔄⦇Obj⦈" for a
      using that by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

lemma tdghm_dghm_comp_is_tdghm'[dg_cs_intros]:
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔅 ↦↦DGα ℭ" 
    and "ℌ : 𝔄 ↦↦DGα 𝔅"
    and "𝔉' = 𝔉 ∘DGHM ℌ"
    and "𝔊' = 𝔊 ∘DGHM ℌ"
  shows "𝔑 ∘TDGHM-DGHM ℌ : 𝔉' ↦DGHM 𝔊' : 𝔄 ↦↦DGα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule tdghm_dghm_comp_is_tdghm)


subsubsection‹Further properties›

lemma tdghm_dghm_comp_tdghm_dghm_comp_assoc:
  assumes "𝔑 : ℌ ↦DGHM ℌ' : ℭ ↦↦DGα 𝔇" 
    and "𝔊 : 𝔅 ↦↦DGα ℭ" 
    and "𝔉 : 𝔄 ↦↦DGα 𝔅"
  shows "(𝔑 ∘TDGHM-DGHM 𝔊) ∘TDGHM-DGHM 𝔉 = 𝔑 ∘TDGHM-DGHM (𝔊 ∘DGHM 𝔉)"
proof-
  interpret 𝔑: is_tdghm α ℭ 𝔇 ℌ ℌ' 𝔑 by (rule assms(1))
  interpret 𝔊: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(2))
  interpret 𝔉: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(3))
  show ?thesis  
  proof(rule tdghm_eqI)
    from assms show 
      "(𝔑 ∘TDGHM-DGHM 𝔊) ∘TDGHM-DGHM 𝔉 :
        ℌ ∘DGHM 𝔊 ∘DGHM 𝔉 ↦DGHM ℌ' ∘DGHM 𝔊 ∘DGHM 𝔉 :
        𝔄 ↦↦DGα 𝔇"
      by (cs_concl cs_intro: dg_cs_intros)
    then have dom_lhs: "𝒟∘ (((𝔑 ∘TDGHM-DGHM 𝔊) ∘TDGHM-DGHM 𝔉)⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (cs_concl cs_simp: dg_cs_simps)
    show "𝔑 ∘TDGHM-DGHM (𝔊 ∘DGHM 𝔉) :
      ℌ ∘DGHM 𝔊 ∘DGHM 𝔉 ↦DGHM ℌ' ∘DGHM 𝔊 ∘DGHM 𝔉 :
      𝔄 ↦↦DGα 𝔇"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    then have dom_rhs: "𝒟∘ ((𝔑 ∘TDGHM-DGHM (𝔊 ∘DGHM 𝔉))⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (cs_concl cs_simp: dg_cs_simps)
    show 
      "((𝔑 ∘TDGHM-DGHM 𝔊) ∘TDGHM-DGHM 𝔉)⦇NTMap⦈ = 
        (𝔑 ∘TDGHM-DGHM (𝔊 ∘DGHM 𝔉))⦇NTMap⦈"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      with assms show 
        "((𝔑 ∘TDGHM-DGHM 𝔊) ∘TDGHM-DGHM 𝔉)⦇NTMap⦈⦇a⦈ =
          (𝔑 ∘TDGHM-DGHM (𝔊 ∘DGHM 𝔉))⦇NTMap⦈⦇a⦈"
        by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    qed (cs_concl cs_intro: dg_cs_intros)
  qed simp_all
qed

lemma (in is_tdghm) tdghm_tdghm_dghm_comp_dghm_id[dg_cs_simps]:
  "𝔑 ∘TDGHM-DGHM dghm_id 𝔄 = 𝔑"
proof(rule tdghm_eqI)
  show "𝔑 ∘TDGHM-DGHM dghm_id 𝔄 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  have dom_lhs: "𝒟∘ ((𝔑 ∘TDGHM-DGHM dghm_id 𝔄)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "(𝔑 ∘TDGHM-DGHM dghm_id 𝔄)⦇NTMap⦈ = 𝔑⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    then show "(𝔑 ∘TDGHM-DGHM dghm_id 𝔄)⦇NTMap⦈⦇a⦈ = 𝔑⦇NTMap⦈⦇a⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_intro: dg_cs_intros V_cs_intros)+
qed simp_all

lemmas [dg_cs_simps] = is_tdghm.tdghm_tdghm_dghm_comp_dghm_id



subsection‹
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms
›


subsubsection‹Definition and elementary properties›

definition dghm_tdghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘DGHM-TDGHM› 55)
  where "ℌ ∘DGHM-TDGHM 𝔑 =
    [
      (λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈. ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈),
      ℌ ∘DGHM 𝔑⦇NTDom⦈,
      ℌ ∘DGHM 𝔑⦇NTCod⦈,
      𝔑⦇NTDGDom⦈,
      ℌ⦇HomCod⦈
    ]∘"


text‹Components.›

lemma dghm_tdghm_comp_components:
  shows "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTMap⦈ =
    (λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈. ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈)"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTDom⦈ = ℌ ∘DGHM 𝔑⦇NTDom⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTCod⦈ = ℌ ∘DGHM 𝔑⦇NTCod⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
    and [dg_shared_cs_simps, dg_cs_simps]: 
      "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTDGCod⦈ = ℌ⦇HomCod⦈"
  unfolding dghm_tdghm_comp_def nt_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Transformation map›

mk_VLambda dghm_tdghm_comp_components(1)
  |vsv dghm_tdghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|

mk_VLambda (in is_tdghm) 
  dghm_tdghm_comp_components(1)[where 𝔑=𝔑, unfolded tdghm_NTDGDom]
  |vdomain dghm_tdghm_comp_NTMap_vdomain|
  |app dghm_tdghm_comp_NTMap_app|

lemmas [dg_cs_simps] = 
  is_tdghm.dghm_tdghm_comp_NTMap_vdomain
  is_tdghm.dghm_tdghm_comp_NTMap_app

lemma dghm_tdghm_comp_NTMap_vrange: 
  assumes "ℌ : 𝔅 ↦↦DGα ℭ" and "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
  shows "ℛ∘ ((ℌ ∘DGHM-TDGHM 𝔑)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret ℌ: is_dghm α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis 
    unfolding dghm_tdghm_comp_components
  proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
    fix x assume "x ∈∘ 𝔄⦇Obj⦈"
    then show "ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇x⦈⦈ ∈∘ ℭ⦇Arr⦈"
      by (cs_concl cs_intro: dg_cs_intros)
  qed
qed


subsubsection‹
Opposite of the composition of a digraph homomorphism 
and a transformation of digraph homomorphisms
›

lemma op_tdghm_dghm_tdghm_comp[dg_op_simps]: 
  "op_tdghm (ℌ ∘DGHM-TDGHM 𝔑) = op_dghm ℌ ∘DGHM-TDGHM op_tdghm 𝔑"
  unfolding 
    dghm_tdghm_comp_def
    dghm_comp_def
    op_tdghm_def
    op_dghm_def
    op_dg_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms is a transformation of digraph homomorphisms
›

lemma dghm_tdghm_comp_is_tdghm:
  assumes "ℌ : 𝔅 ↦↦DGα ℭ" and "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
  shows "ℌ ∘DGHM-TDGHM 𝔑 : ℌ ∘DGHM 𝔉 ↦DGHM ℌ ∘DGHM 𝔊 : 𝔄 ↦↦DGα ℭ"
proof-
  interpret ℌ: is_dghm α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis
  proof(rule is_tdghmI)
    show "vfsequence (ℌ ∘DGHM-TDGHM 𝔑)"
      unfolding dghm_tdghm_comp_def by simp
    show "vcard (ℌ ∘DGHM-TDGHM 𝔑) = 5ℕ"
      unfolding dghm_tdghm_comp_def  by (simp add: nat_omega_simps)
    show "(ℌ ∘DGHM-TDGHM 𝔑)⦇NTMap⦈⦇a⦈ : 
      (ℌ ∘DGHM 𝔉)⦇ObjMap⦈⦇a⦈ ↦ℭ (ℌ ∘DGHM 𝔊)⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝔄⦇Obj⦈" for a
      using that by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

lemma dghm_tdghm_comp_is_tdghm'[dg_cs_intros]:
  assumes "ℌ : 𝔅 ↦↦DGα ℭ"
    and "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    and "𝔉' = ℌ ∘DGHM 𝔉"
    and "𝔊' = ℌ ∘DGHM 𝔊"
  shows "ℌ ∘DGHM-TDGHM 𝔑 : 𝔉' ↦DGHM 𝔊' : 𝔄 ↦↦DGα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule dghm_tdghm_comp_is_tdghm)


subsubsection‹Further properties›

lemma dghm_comp_dghm_tdghm_comp_assoc:
  assumes "𝔑 : ℌ ↦DGHM ℌ' : 𝔄 ↦↦DGα 𝔅"
    and "𝔉 : 𝔅 ↦↦DGα ℭ"
    and "𝔊 : ℭ ↦↦DGα 𝔇"
  shows "(𝔊 ∘DGHM 𝔉) ∘DGHM-TDGHM 𝔑 = 𝔊 ∘DGHM-TDGHM (𝔉 ∘DGHM-TDGHM 𝔑)"
proof(rule tdghm_eqI)
  interpret 𝔑: is_tdghm α 𝔄 𝔅 ℌ ℌ' 𝔑 by (rule assms(1))
  interpret 𝔉: is_dghm α 𝔅 ℭ 𝔉 by (rule assms(2))
  interpret 𝔊: is_dghm α ℭ 𝔇 𝔊 by (rule assms(3))
  from assms show "(𝔊 ∘DGHM 𝔉) ∘DGHM-TDGHM 𝔑 :
    𝔊 ∘DGHM 𝔉 ∘DGHM ℌ ↦DGHM 𝔊 ∘DGHM 𝔉 ∘DGHM ℌ' : 𝔄 ↦↦DGα 𝔇"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_lhs: "𝒟∘ ((𝔊 ∘DGHM 𝔉 ∘DGHM-TDGHM 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: dg_cs_simps)
  from assms show "𝔊 ∘DGHM-TDGHM (𝔉 ∘DGHM-TDGHM 𝔑) :
    𝔊 ∘DGHM 𝔉 ∘DGHM ℌ ↦DGHM 𝔊 ∘DGHM 𝔉 ∘DGHM ℌ' : 𝔄 ↦↦DGα 𝔇"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_rhs: 
    "𝒟∘ ((𝔊 ∘DGHM-TDGHM (𝔉 ∘DGHM-TDGHM 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: dg_cs_simps)
  show 
    "((𝔊 ∘DGHM 𝔉) ∘DGHM-TDGHM 𝔑)⦇NTMap⦈ = 
      (𝔊 ∘DGHM-TDGHM (𝔉 ∘DGHM-TDGHM 𝔑))⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    then show 
      "(𝔊 ∘DGHM 𝔉 ∘DGHM-TDGHM 𝔑)⦇NTMap⦈⦇a⦈ =
        (𝔊 ∘DGHM-TDGHM (𝔉 ∘DGHM-TDGHM 𝔑))⦇NTMap⦈⦇a⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed simp_all

lemma (in is_tdghm) tdghm_dghm_tdghm_comp_dghm_id[dg_cs_simps]:
  "dghm_id 𝔅 ∘DGHM-TDGHM 𝔑 = 𝔑"
proof(rule tdghm_eqI)
  show "dghm_id 𝔅 ∘DGHM-TDGHM 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  then have dom_lhs: "𝒟∘ ((dghm_id 𝔅 ∘DGHM-TDGHM 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: dg_cs_simps)
  show "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  show "(dghm_id 𝔅 ∘DGHM-TDGHM 𝔑)⦇NTMap⦈ = 𝔑⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
    show "vsv (𝔑⦇NTMap⦈)" by auto
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    then show "(dghm_id 𝔅 ∘DGHM-TDGHM 𝔑)⦇NTMap⦈⦇a⦈ = 𝔑⦇NTMap⦈⦇a⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed (cs_concl cs_intro: dg_cs_intros)+
qed simp_all

lemmas [dg_cs_simps] = is_tdghm.tdghm_dghm_tdghm_comp_dghm_id

lemma dghm_tdghm_comp_tdghm_dghm_comp_assoc:
  assumes "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔅 ↦↦DGα ℭ"
    and "ℌ : ℭ ↦↦DGα 𝔇"
    and "𝔎 : 𝔄 ↦↦DGα 𝔅"
  shows "(ℌ ∘DGHM-TDGHM 𝔑) ∘TDGHM-DGHM 𝔎 = ℌ ∘DGHM-TDGHM (𝔑 ∘TDGHM-DGHM 𝔎)"
proof-
  interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_dghm α ℭ 𝔇 ℌ by (rule assms(2))
  interpret 𝔎: is_dghm α 𝔄 𝔅 𝔎 by (rule assms(3))
  show ?thesis
  proof(rule tdghm_eqI)
    from assms have dom_lhs: 
      "𝒟∘ (((ℌ ∘DGHM-TDGHM 𝔑) ∘TDGHM-DGHM 𝔎)⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (cs_concl cs_simp: dg_cs_simps)
    from assms have dom_rhs: 
      "𝒟∘ ((ℌ ∘DGHM-TDGHM (𝔑 ∘TDGHM-DGHM 𝔎))⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    show 
      "((ℌ ∘DGHM-TDGHM 𝔑) ∘TDGHM-DGHM 𝔎)⦇NTMap⦈ =
        (ℌ ∘DGHM-TDGHM (𝔑 ∘TDGHM-DGHM 𝔎))⦇NTMap⦈"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      then show 
        "((ℌ ∘DGHM-TDGHM 𝔑) ∘TDGHM-DGHM 𝔎)⦇NTMap⦈⦇a⦈ =
          ((ℌ ∘DGHM-TDGHM (𝔑 ∘TDGHM-DGHM 𝔎)))⦇NTMap⦈⦇a⦈"
        by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    qed (cs_concl cs_intro: dg_cs_intros)
  qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed

text‹\newpage›

end

Theory CZH_DG_Small_TDGHM

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for transformations of digraph homomorphisms›
theory CZH_DG_Small_TDGHM
  imports 
    CZH_DG_Small_DGHM
    CZH_DG_TDGHM
begin



subsection‹Transformation of digraph homomorphisms with tiny maps›


subsubsection‹Definition and elementary properties›

locale is_tm_tdghm = 
  𝒵 α + 
  NTDom: is_tm_dghm α 𝔄 𝔅 𝔉 +
  NTCod: is_tm_dghm α 𝔄 𝔅 𝔊 +
  is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑
  for α 𝔄 𝔅 𝔉 𝔊 𝔑

syntax "_is_tm_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦DGHM.tm _ :/ _ ↦↦DG.tmı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅" ⇌
  "CONST is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_tm_tdghms :: "V ⇒ V"
  where "all_tm_tdghms α ≡
    set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"

abbreviation tm_tdghms :: "V ⇒ V ⇒ V ⇒ V"
  where "tm_tdghms α 𝔄 𝔅 ≡
    set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"

abbreviation these_tm_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_tm_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡ 
    set {𝔑. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"


text‹Rules.›

lemma (in is_tm_tdghm) is_tm_tdghm_axioms'[dg_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "𝔑 : 𝔉' ↦DGHM.tm 𝔊' : 𝔄' ↦↦DG.tmα' 𝔅'"
  unfolding assms by (rule is_tm_tdghm_axioms)

mk_ide rf is_tm_tdghm_def
  |intro is_tm_tdghmI|
  |dest is_tm_tdghmD[dest]|
  |elim is_tm_tdghmE[elim]|

lemmas [dg_small_cs_intros] = is_tm_tdghmD(2,3,4)


text‹Size.›

lemma (in is_tm_tdghm) tm_tdghm_NTMap_in_Vset: "𝔑⦇NTMap⦈ ∈∘ Vset α"
proof-
  show ?thesis
  proof(rule vbrelation.vbrelation_Limit_in_VsetI)
    have "(⋃∘a∈∘ℛ∘ (𝔉⦇ObjMap⦈). ⋃∘b∈∘ℛ∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b) ∈∘ Vset α"
      by 
        (
          intro 
            NTDom.HomCod.dg_Hom_vifunion_in_Vset
            NTDom.dghm_ObjMap_vrange 
            NTDom.tm_dghm_ObjMap_in_Vset 
            NTCod.dghm_ObjMap_vrange 
            NTCod.tm_dghm_ObjMap_in_Vset
            vrange_in_VsetI
        )+
    moreover have 
      "ℛ∘ (𝔑⦇NTMap⦈) ⊆∘ (⋃∘a∈∘ℛ∘ (𝔉⦇ObjMap⦈). ⋃∘b∈∘ℛ∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
      by (rule tdghm_NTMap_vrange_vifunion)
    ultimately show "ℛ∘ (𝔑⦇NTMap⦈) ∈∘ Vset α" by (auto simp: dg_cs_simps)
  qed 
    (
      insert NTCod.tm_dghm_HomDom_is_tiny_digraph, 
      auto intro!: NTMap.vbrelation_axioms simp: dg_cs_simps
    )
qed

lemma small_all_tm_tdghms[simp]: 
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"
proof(rule down)
  show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅} ⊆
    elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_tdghms if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅"
    then obtain 𝔉 𝔊 𝔄 𝔅 where 𝔑: "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅"
      by clarsimp
    interpret is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔑)
    have "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" by (auto intro: dg_cs_intros)
    then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" by auto
  qed
qed

lemma small_tm_tdghms[simp]: 
  "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}›
          ]
    )
    auto

lemma small_these_tm_tdghms[simp]: 
  "small {𝔑. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅}›
          ]
    ) 
    auto


text‹Further elementary results.›

lemma these_tm_tdghms_iff: (*not simp*)
  "𝔑 ∈∘ these_tm_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷
    𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅"
  by auto


subsubsection‹
Opposite transformation of digraph homomorphisms with tiny maps
›

lemma (in is_tm_tdghm) is_tm_tdghm_op:
  "op_tdghm 𝔑 : op_dghm 𝔊 ↦DGHM.tm op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.tmα op_dg 𝔅"
  by (intro is_tm_tdghmI)
    (cs_concl cs_intro: dg_cs_intros dg_op_intros)+

lemma (in is_tm_tdghm) is_tm_tdghm_op'[dg_op_intros]: 
  assumes "𝔊' = op_dghm 𝔊"
    and "𝔉' = op_dghm 𝔉"
    and "𝔄' = op_dg 𝔄"
    and "𝔅' = op_dg 𝔅"
  shows "op_tdghm 𝔑 : 𝔊' ↦DGHM.tm 𝔉' : 𝔄' ↦↦DG.tmα 𝔅'"
  unfolding assms by (rule is_tm_tdghm_op)

lemmas is_tm_tdghm_op[dg_op_intros] = is_tm_tdghm.is_tm_tdghm_op'


subsubsection‹
Composition of a transformation of digraph homomorphisms with tiny
maps and a digraph homomorphism with tiny maps
›

lemma tdghm_dghm_comp_is_tm_tdghm:
  assumes "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔅 ↦↦DG.tmα ℭ" and "ℌ : 𝔄 ↦↦DG.tmα 𝔅"
  shows "𝔑 ∘TDGHM-DGHM ℌ : 𝔉 ∘DGHM ℌ ↦DGHM.tm 𝔊 ∘DGHM ℌ : 𝔄 ↦↦DG.tmα ℭ"
proof-
  interpret 𝔑: is_tm_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_tm_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
  show ?thesis
    by (rule is_tm_tdghmI)
      (
        cs_concl
          cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros
      )+
qed

lemma tdghm_dghm_comp_is_tm_tdghm'[dg_small_cs_intros]:
  assumes "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔅 ↦↦DG.tmα ℭ" 
    and "ℌ : 𝔄 ↦↦DG.tmα 𝔅"
    and "𝔉' = 𝔉 ∘DGHM ℌ"
    and "𝔊' = 𝔊 ∘DGHM ℌ"
  shows "𝔑 ∘TDGHM-DGHM ℌ : 𝔉' ↦DGHM.tm 𝔊' : 𝔄 ↦↦DG.tmα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule tdghm_dghm_comp_is_tm_tdghm)


subsubsection‹
Composition of a digraph homomorphism with tiny maps and a  
transformation of digraph homomorphisms with tiny maps
›

lemma dghm_tdghm_comp_is_tm_tdghm:
  assumes "ℌ : 𝔅 ↦↦DG.tmα ℭ" and "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅"
  shows "ℌ ∘DGHM-TDGHM 𝔑 : ℌ ∘DGHM 𝔉 ↦DGHM.tm ℌ ∘DGHM 𝔊 : 𝔄 ↦↦DG.tmα ℭ"
proof-
  interpret ℌ: is_tm_dghm α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis
    by (rule is_tm_tdghmI)
      (
        cs_concl
          cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros
      )+
qed

lemma dghm_tdghm_comp_is_tm_tdghm'[dg_small_cs_intros]:
  assumes "ℌ : 𝔅 ↦↦DG.tmα ℭ"
    and "𝔑 : 𝔉 ↦DGHM.tm 𝔊 : 𝔄 ↦↦DG.tmα 𝔅"
    and "𝔉' = ℌ ∘DGHM 𝔉"
    and "𝔊' = ℌ ∘DGHM 𝔊"
  shows "ℌ ∘DGHM-TDGHM 𝔑 : 𝔉' ↦DGHM.tm 𝔊' : 𝔄 ↦↦DG.tmα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule dghm_tdghm_comp_is_tm_tdghm)



subsection‹Transformation of homomorphisms of tiny digraphs›


subsubsection‹Definition and elementary properties›

locale is_tiny_tdghm = 
  𝒵 α + 
  NTDom: is_tiny_dghm α 𝔄 𝔅 𝔉 +
  NTCod: is_tiny_dghm α 𝔄 𝔅 𝔊 +
  is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑
  for α 𝔄 𝔅 𝔉 𝔊 𝔑

syntax "_is_tiny_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦DGHM.tiny _ :/ _ ↦↦DG.tinyı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅" ⇌
  "CONST is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_tiny_tdghms :: "V ⇒ V"
  where "all_tiny_tdghms α ≡ 
    set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"

abbreviation tiny_tdghms :: "V ⇒ V ⇒ V ⇒ V"
  where "tiny_tdghms α 𝔄 𝔅 ≡ 
    set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"

abbreviation these_tiny_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_tiny_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡ 
    set {𝔑. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"


text‹Rules.›

lemmas (in is_tiny_tdghm) [dg_small_cs_intros] = is_tiny_tdghm_axioms

mk_ide rf is_tiny_tdghm_def
  |intro is_tiny_tdghmI[intro]|
  |dest is_tiny_tdghmD[dest]|
  |elim is_tiny_tdghmE[elim]|

lemmas [dg_small_cs_intros] = is_tiny_tdghmD(2,3,4)


text‹Elementary properties.›

sublocale is_tiny_tdghm ⊆ is_tm_tdghm
  by (rule is_tm_tdghmI) 
    (auto simp: vfsequence_axioms dg_cs_intros dg_small_cs_intros)

lemmas (in is_tiny_tdghm) tiny_tdghm_is_tm_tdghm = is_tm_tdghm_axioms

lemmas [dg_small_cs_intros] = is_tiny_tdghm.tiny_tdghm_is_tm_tdghm


text‹Size.›

lemma (in is_tiny_tdghm) tiny_tdghm_in_Vset: "𝔑 ∈∘ Vset α"
proof-
  note [dg_cs_intros] =
    tm_tdghm_NTMap_in_Vset
    NTDom.tiny_dghm_in_Vset
    NTCod.tiny_dghm_in_Vset
    NTDom.HomDom.tiny_dg_in_Vset
    NTDom.HomCod.tiny_dg_in_Vset
  show ?thesis
    by (subst tdghm_def) 
      (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed

lemma small_all_tiny_tdghms[simp]:
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"
proof(rule down)
  show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅} ⊆ 
    elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_tdghms if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅"
    then obtain 𝔉 𝔊 𝔄 𝔅 where 𝔑: "𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅"
      by clarsimp
    interpret is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔑)
    have "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" by (auto intro: dg_cs_intros)
    then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGα 𝔅" by auto
  qed
qed

lemma small_tiny_tdghms[simp]: 
  "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}›
          ]
    )
    auto

lemma small_these_tiny_tdghms[simp]: 
  "small {𝔑. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅}›
          ]
    ) 
    auto

lemma tiny_tdghms_vsubset_Vset[simp]: 
  "set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅} ⊆∘ Vset α"
  (is ‹set ?tdghms ⊆∘ _›)
proof(cases ‹tiny_digraph α 𝔄 ∧ tiny_digraph α 𝔅›)
  case True
  then have "tiny_digraph α 𝔄" and "tiny_digraph α 𝔅" by auto
  show ?thesis 
  proof(rule vsubsetI)
    fix 𝔑 assume "𝔑 ∈∘ set ?tdghms"
    then obtain 𝔉 𝔊 where 𝔉: "𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅" 
      by clarsimp
    interpret is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔉)
    from tiny_tdghm_in_Vset show "𝔑 ∈∘ Vset α" by simp
  qed
next
  case False
  then have "set ?tdghms = 0" by fastforce
  then show ?thesis by simp
qed

lemma (in is_tdghm) tdghm_is_tiny_tdghm_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyβ 𝔅" 
proof(intro is_tiny_tdghmI)
  interpret β: 𝒵 β by (rule assms(1))
  show "𝔑 : 𝔉 ↦DGHM 𝔊 : 𝔄 ↦↦DGβ 𝔅"
    by (intro tdghm_is_tdghm_if_ge_Limit)
      (use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
  show "𝔉 : 𝔄 ↦↦DG.tinyβ 𝔅" "𝔊 : 𝔄 ↦↦DG.tinyβ 𝔅"
    by 
      (
        simp_all add:
          NTDom.dghm_is_tiny_dghm_if_ge_Limit
          NTCod.dghm_is_tiny_dghm_if_ge_Limit
          β.𝒵_axioms 
          assms(2)
      )
qed (rule assms(1))


text‹Further elementary results.›

lemma these_tiny_tdghms_iff: (*not simp*)
  "𝔑 ∈∘ these_tiny_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷
    𝔑 : 𝔉 ↦DGHM.tiny 𝔊 : 𝔄 ↦↦DG.tinyα 𝔅"
  by auto


subsubsection‹Opposite transformation of homomorphisms of tiny digraphs›

lemma (in is_tiny_tdghm) is_tm_tdghm_op: "op_tdghm 𝔑 :
  op_dghm 𝔊 ↦DGHM.tiny op_dghm 𝔉 : op_dg 𝔄 ↦↦DG.tinyα op_dg 𝔅"
  by (intro is_tiny_tdghmI)
   (cs_concl cs_intro: dg_cs_intros dg_op_intros)+

lemma (in is_tiny_tdghm) is_tiny_tdghm_op'[dg_op_intros]: 
  assumes "𝔊' = op_dghm 𝔊"
    and "𝔉' = op_dghm 𝔉"
    and "𝔄' = op_dg 𝔄"
    and "𝔅' = op_dg 𝔅"
  shows "op_tdghm 𝔑 : 𝔊' ↦DGHM.tiny 𝔉' : 𝔄' ↦↦DG.tinyα 𝔅'"
  unfolding assms by (rule is_tm_tdghm_op)

lemmas is_tiny_tdghm_op[dg_op_intros] = is_tiny_tdghm.is_tiny_tdghm_op'

text‹\newpage›

end

Theory CZH_DG_PDigraph

(* Copyright 2021 (C) Mihails Milehins *)

section‹Product digraph›
theory CZH_DG_PDigraph
  imports 
    CZH_DG_TDGHM
    CZH_DG_Small_Digraph
begin



subsection‹Background›


text‹
The concept of a product digraph, as presented in this work, 
is a generalization of the concept of a product category,
as presented in Chapter II-3 in \cite{mac_lane_categories_2010}.
›

named_theorems dg_prod_cs_simps
named_theorems dg_prod_cs_intros



subsection‹Product digraph: definition and elementary properties›

definition dg_prod :: "V ⇒ (V ⇒ V) ⇒ V"
  where "dg_prod I 𝔄 =
    [
      (∏∘i∈∘I. 𝔄 i⦇Obj⦈),
      (∏∘i∈∘I. 𝔄 i⦇Arr⦈),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))
    ]∘"

syntax "_PDIGRAPH" :: "pttrn ⇒ V ⇒ (V ⇒ V) ⇒ V"
  (‹(3∏DG_∈∘_./ _)› [0, 0, 10] 10)
translations "∏DGi∈∘I. 𝔄" ⇌ "CONST dg_prod I (λi. 𝔄)"


text‹Components.›

lemma dg_prod_components:
  shows "(∏DGi∈∘I. 𝔄 i)⦇Obj⦈ = (∏∘i∈∘I. 𝔄 i⦇Obj⦈)"
    and "(∏DGi∈∘I. 𝔄 i)⦇Arr⦈ = (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
    and "(∏DGi∈∘I. 𝔄 i)⦇Dom⦈ =
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈))"
    and "(∏DGi∈∘I. 𝔄 i)⦇Cod⦈ =
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))"
  unfolding dg_prod_def dg_field_simps by (simp_all add: nat_omega_simps)



subsection‹Local assumptions for a product digraph›

locale pdigraph_base = 𝒵 α for α I and 𝔄 :: "V ⇒ V" +
  assumes pdg_digraphs[dg_prod_cs_intros]: "i ∈∘ I ⟹ digraph α (𝔄 i)"
    and pdg_index_in_Vset[dg_cs_intros]: "I ∈∘ Vset α"


text‹Rules.›

lemma (in pdigraph_base) pdigraph_base_axioms'[dg_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "pdigraph_base α' I' 𝔄"
  unfolding assms by (rule pdigraph_base_axioms)

mk_ide rf pdigraph_base_def[unfolded pdigraph_base_axioms_def]
  |intro pdigraph_baseI|
  |dest pdigraph_baseD[dest]|
  |elim pdigraph_baseE[elim]|


text‹Elementary properties.›

lemma (in pdigraph_base) pdg_Obj_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β" 
  shows "(∏∘i∈∘I. 𝔄 i⦇Obj⦈) ∈∘ Vset β"
proof(rule Vset_trans)
  interpret β: 𝒵 β by (rule assms(1))
  show "(∏∘i∈∘I. 𝔄 i⦇Obj⦈) ∈∘ Vset (succ (succ α))"
  proof
    (
      rule vsubset_in_VsetI,
      rule Limit_vproduct_vsubset_Vset_succI,
      rule Limit_α,
      intro dg_cs_intros
    )
    show "Vset (succ α) ∈∘ Vset (succ (succ α))" 
      by (cs_concl cs_intro: V_cs_intros)
    fix i assume prems: "i ∈∘ I"
    interpret digraph α ‹𝔄 i›
      using prems by (cs_concl cs_intro: dg_cs_intros dg_prod_cs_intros)
    show "𝔄 i⦇Obj⦈ ⊆∘ Vset α" by (rule dg_Obj_vsubset_Vset)
  qed
  from assms(2) show "Vset (succ (succ α)) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros succ_in_Limit_iff[THEN iffD2])
qed

lemma (in pdigraph_base) pdg_Arr_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β" 
  shows "(∏∘i∈∘I. 𝔄 i⦇Arr⦈) ∈∘ Vset β"
proof(rule Vset_trans)
  interpret β: 𝒵 β by (rule assms(1))
  show "(∏∘i∈∘I. 𝔄 i⦇Arr⦈) ∈∘ Vset (succ (succ α))"
  proof
    (
      rule vsubset_in_VsetI,
      rule Limit_vproduct_vsubset_Vset_succI,
      rule Limit_α,
      intro dg_cs_intros
    )
    fix i assume "i ∈∘ I"
    then interpret digraph α ‹𝔄 i› 
      by (cs_concl cs_intro: dg_prod_cs_intros)
    show "𝔄 i⦇Arr⦈ ⊆∘ Vset α" by (rule dg_Arr_vsubset_Vset)
  qed (cs_concl cs_intro: V_cs_intros)
  from assms(2) show "Vset (succ (succ α)) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros succ_in_Limit_iff[THEN iffD2])
qed

lemmas_with (in pdigraph_base) [folded dg_prod_components]:
  pdg_dg_prod_Obj_in_Vset[dg_cs_intros] = pdg_Obj_in_Vset
  and pdg_dg_prod_Arr_in_Vset[dg_cs_intros] = pdg_Arr_in_Vset

lemma (in pdigraph_base) pdg_vsubset_index_pdigraph_base:
  assumes "J ⊆∘ I"
  shows "pdigraph_base α J 𝔄"
  using assms
  by (intro pdigraph_baseI)
    (auto simp: vsubset_in_VsetI dg_cs_intros intro: dg_prod_cs_intros)


subsubsection‹Object›

lemma dg_prod_ObjI:
  assumes "vsv a" and "𝒟∘ a = I" and "⋀i. i ∈∘ I ⟹ a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
  shows "a ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_prod_ObjD:
  assumes "a ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈" 
  shows "vsv a" and "𝒟∘ a = I" and "⋀i. i ∈∘ I ⟹ a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_prod_ObjE:
  assumes "a ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈" 
  obtains "vsv a" and "𝒟∘ a = I" and "⋀i. i ∈∘ I ⟹ a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
  using assms by (auto dest: dg_prod_ObjD)

lemma dg_prod_Obj_cong:
  assumes "g ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
    and "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
    and "⋀i. i ∈∘ I ⟹ g⦇i⦈ = f⦇i⦈"
  shows "g = f"
  using assms by (intro vsv_eqI[of g f]) (force simp: dg_prod_components)+


subsubsection‹Arrow›

lemma dg_prod_ArrI:
  assumes "vsv f" and "𝒟∘ f = I" and "⋀i. i ∈∘ I ⟹ f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
  shows "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_prod_ArrD:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈" 
  shows "vsv f" and "𝒟∘ f = I" and "⋀i. i ∈∘ I ⟹ f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_prod_ArrE:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈" 
  obtains "vsv f" and "𝒟∘ f = I" and "⋀i. i ∈∘ I ⟹ f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
  using assms by (auto dest: dg_prod_ArrD)

lemma dg_prod_Arr_cong:
  assumes "g ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    and "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    and "⋀i. i ∈∘ I ⟹ g⦇i⦈ = f⦇i⦈"
  shows "g = f"
  using assms by (intro vsv_eqI[of g f]) (force simp: dg_prod_components)+


subsubsection‹Domain›

mk_VLambda dg_prod_components(3)
  |vsv dg_prod_Dom_vsv[dg_cs_intros]|
  |vdomain dg_prod_Dom_vdomain[folded dg_prod_components, dg_cs_simps]|
  |app dg_prod_Dom_app[folded dg_prod_components]|

lemma (in pdigraph_base) dg_prod_Dom_app_in_Obj[dg_cs_intros]:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
  shows "(∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈ ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
  unfolding dg_prod_components(1) dg_prod_Dom_app[OF assms]
proof(intro vproductI ballI)
  fix i assume prems: "i ∈∘ I" 
  interpret digraph α ‹𝔄 i› 
    by (auto simp: prems intro: dg_prod_cs_intros)
  from assms prems show "(λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
    unfolding dg_prod_components(2) by force
qed simp_all

lemma dg_prod_Dom_app_component_app[dg_cs_simps]:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈" and "i ∈∘ I"
  shows "(∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈⦇i⦈ = 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈"
  using assms(2) unfolding dg_prod_Dom_app[OF assms(1)] by simp


subsubsection‹Codomain›

mk_VLambda dg_prod_components(4)
  |vsv dg_prod_Cod_vsv[dg_cs_intros]|
  |vdomain dg_prod_Cod_vdomain[folded dg_prod_components, dg_cs_simps]|
  |app dg_prod_Cod_app[folded dg_prod_components]|

lemma (in pdigraph_base) dg_prod_Cod_app_in_Obj[dg_cs_intros]:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
  shows "(∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈ ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
  unfolding dg_prod_components(1) dg_prod_Cod_app[OF assms]
proof(rule vproductI)
  show "∀i∈∘I. (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
  proof(intro ballI)
    fix i assume prems: "i ∈∘ I" 
    then interpret digraph α ‹𝔄 i› 
      by (auto intro: dg_prod_cs_intros)
    from assms prems show "(λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
      unfolding dg_prod_components(2) by force
  qed
qed simp_all

lemma dg_prod_Cod_app_component_app[dg_cs_simps]:
  assumes "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈" and "i ∈∘ I"
  shows "(∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈⦇i⦈ = 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈"
  using assms(2) unfolding dg_prod_Cod_app[OF assms(1)] by simp


subsubsection‹A product ‹α›-digraph is a tiny ‹β›-digraph›

lemma (in pdigraph_base) pdg_tiny_digraph_dg_prod:
  assumes "𝒵 β" and "α ∈∘ β" 
  shows "tiny_digraph β (∏DGi∈∘I. 𝔄 i)"
proof(intro tiny_digraphI)
  show "vfsequence (∏DGi∈∘I. 𝔄 i)" unfolding dg_prod_def by simp
  show "vcard (∏DGi∈∘I. 𝔄 i) = 4ℕ"
    unfolding dg_prod_def by (simp add: nat_omega_simps)
  show vsv_dg_prod_Dom: "vsv ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈)" 
    unfolding dg_prod_components by simp
  show vdomain_dg_prod_Dom: "𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈) = (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    unfolding dg_prod_components by simp
  show "ℛ∘ ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"  
    by (rule vsubsetI)
      (
        metis 
          dg_prod_Dom_app_in_Obj 
          dg_prod_Dom_vdomain 
          vsv.vrange_atE 
          vsv_dg_prod_Dom
      )
  show vsv_dg_prod_Cod: "vsv ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈)" 
    unfolding dg_prod_components by auto
  show vdomain_dg_prod_Cod: "𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈) = (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    unfolding dg_prod_components by auto
  show "ℛ∘ ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"  
    by (rule vsubsetI)
      (
        metis 
          dg_prod_Cod_app_in_Obj 
          vdomain_dg_prod_Cod 
          vsv.vrange_atE 
          vsv_dg_prod_Cod
      )
qed 
  (
    auto simp:
      dg_cs_intros
      assms 
      pdg_dg_prod_Arr_in_Vset[OF assms(1,2)]
      pdg_dg_prod_Obj_in_Vset[OF assms(1,2)]
  )


lemma (in pdigraph_base) pdg_tiny_digraph_dg_prod': 
  "tiny_digraph (α + ω) (∏DGi∈∘I. 𝔄 i)"
  by (rule pdg_tiny_digraph_dg_prod)
    (simp_all add: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)


subsubsection‹Arrow with a domain and a codomain›

lemma (in pdigraph_base) dg_prod_is_arrI:
  assumes "vsv f"
    and "𝒟∘ f = I"
    and "vsv a"
    and "𝒟∘ a = I"
    and "vsv b"
    and "𝒟∘ b = I"
    and "⋀i. i ∈∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈"
  shows "f : a ↦∏DGi∈∘I. 𝔄 i b"
proof(intro is_arrI)
  interpret f: vsv f by (rule assms(1))
  interpret a: vsv a by (rule assms(3))
  interpret b: vsv b by (rule assms(5))
  from assms(7) have f_components: "⋀i. i ∈∘ I ⟹ f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈" by auto
  from assms(7) have a_components: "⋀i. i ∈∘ I ⟹ a⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
    by (meson digraph.dg_is_arrD(2) pdg_digraphs)
  from assms(7) have b_components: "⋀i. i ∈∘ I ⟹ b⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
    by (meson digraph.dg_is_arrD(3) pdg_digraphs)
  show f_in_Arr: "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    unfolding dg_prod_components
    by (intro vproductI)
      (auto simp: f_components assms(2) f.vsv_vrange_vsubset_vifunion_app)
  show "(∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈ = a"
  proof(rule vsv_eqI)
    from dg_prod_Dom_app_in_Obj[OF f_in_Arr] show "vsv ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈)"
      unfolding dg_prod_components by clarsimp
    from dg_prod_Dom_app_in_Obj[OF f_in_Arr] assms(4) show [simp]:
      "𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈) = 𝒟∘ a"
      unfolding dg_prod_components by clarsimp
    fix i assume "i ∈∘ 𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈)"
    then have i: "i ∈∘ I" by (simp add: assms(4))
    from a_components assms(7) i show "(∏DGi∈∘I. 𝔄 i)⦇Dom⦈⦇f⦈⦇i⦈ = a⦇i⦈"
      unfolding dg_prod_Dom_app_component_app[OF f_in_Arr i] by auto
  qed auto
  show "(∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈ = b"
  proof(rule vsv_eqI)
    from dg_prod_Cod_app_in_Obj[OF f_in_Arr] show "vsv ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈)"
      unfolding dg_prod_components by clarsimp
    from dg_prod_Cod_app_in_Obj[OF f_in_Arr] assms(6) show [simp]:
      "𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈) = 𝒟∘ b"
      unfolding dg_prod_components by clarsimp
    fix i assume "i ∈∘ 𝒟∘ ((∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈)"
    then have i: "i ∈∘ I" by (simp add: assms(6))
    from b_components assms(7) i show "(∏DGi∈∘I. 𝔄 i)⦇Cod⦈⦇f⦈⦇i⦈ = b⦇i⦈"
      unfolding dg_prod_Cod_app_component_app[OF f_in_Arr i] by auto
  qed auto
qed

lemma (in pdigraph_base) dg_prod_is_arrD[dest]:
  assumes "f : a ↦∏DGi∈∘I. 𝔄 i b"
  shows "vsv f"
    and "𝒟∘ f = I"
    and "vsv a"
    and "𝒟∘ a = I"
    and "vsv b"
    and "𝒟∘ b = I"
    and "⋀i. i ∈∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈"
proof-
  from is_arrD[OF assms] have f: "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    and a: "a ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈" 
    and b: "b ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈" 
    by (auto intro: dg_cs_intros)
  then show "𝒟∘ f = I" "𝒟∘ a = I" "𝒟∘ b = I" "vsv f" "vsv a" "vsv b"
    unfolding dg_prod_components by auto
  fix i assume prems: "i ∈∘ I"
  show "f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈"
  proof(intro is_arrI)
    from assms(1) have f: "f ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
      and a: "a ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
      and b: "b ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
    by (auto intro: dg_cs_intros)
    from f prems show "f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
      unfolding dg_prod_components by clarsimp
    from a b assms(1) prems dg_prod_components(2,3,4) show 
      "𝔄 i⦇Dom⦈⦇f⦇i⦈⦈ = a⦇i⦈" "𝔄 i⦇Cod⦈⦇f⦇i⦈⦈ = b⦇i⦈"
      by fastforce+
  qed
qed

lemma (in pdigraph_base) dg_prod_is_arrE[elim]:
  assumes "f : a ↦∏DGi∈∘I. 𝔄 i b"
  obtains "vsv f"
    and "𝒟∘ f = I"
    and "vsv a"
    and "𝒟∘ a = I"
    and "vsv b"
    and "𝒟∘ b = I"
    and "⋀i. i ∈∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈"
  using assms by auto



subsection‹Further local assumptions for product digraphs›


subsubsection‹Definition and elementary properties›

locale pdigraph = pdigraph_base α I 𝔄 for α I 𝔄 +
  assumes pdg_Obj_vsubset_Vset: "J ⊆∘ I ⟹ (∏DGi∈∘J. 𝔄 i)⦇Obj⦈ ⊆∘ Vset α"
    and pdg_Hom_vifunion_in_Vset: 
      "⟦
        J ⊆∘ I;
        A ⊆∘ (∏DGi∈∘J. 𝔄 i)⦇Obj⦈;
        B ⊆∘ (∏DGi∈∘J. 𝔄 i)⦇Obj⦈;
        A ∈∘ Vset α;
        B ∈∘ Vset α
      ⟧ ⟹ (⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J. 𝔄 i) a b) ∈∘ Vset α"


text‹Rules.›

lemma (in pdigraph) pdigraph_axioms'[dg_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "pdigraph α' I' 𝔄"
  unfolding assms by (rule pdigraph_axioms)

mk_ide rf pdigraph_def[unfolded pdigraph_axioms_def]
  |intro pdigraphI|
  |dest pdigraphD[dest]|
  |elim pdigraphE[elim]|

lemmas [dg_prod_cs_intros] = pdigraphD(1)


text‹Elementary properties.›

lemma (in pdigraph) pdg_Obj_vsubset_Vset': "(∏DGi∈∘I. 𝔄 i)⦇Obj⦈ ⊆∘ Vset α"
  by (rule pdg_Obj_vsubset_Vset) simp

lemma (in pdigraph) pdg_Hom_vifunion_in_Vset':
  assumes "A ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
    and "B ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
    and "A ∈∘ Vset α"
    and "B ∈∘ Vset α"
  shows "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘I. 𝔄 i) a b) ∈∘ Vset α"
  using assms by (intro pdg_Hom_vifunion_in_Vset) simp_all

lemma (in pdigraph) pdg_vsubset_index_pdigraph:
  assumes "J ⊆∘ I"
  shows "pdigraph α J 𝔄"
proof(intro pdigraphI)
  show "dg_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" if ‹J' ⊆∘ J› for J'
  proof-
    from that assms have "J' ⊆∘ I" by simp
    then show "dg_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" by (rule pdg_Obj_vsubset_Vset)
  qed
  fix A B J' assume prems: 
    "J' ⊆∘ J"
    "A ⊆∘ (∏DGi∈∘J'. 𝔄 i)⦇Obj⦈"
    "B ⊆∘ (∏DGi∈∘J'. 𝔄 i)⦇Obj⦈"
    "A ∈∘ Vset α" 
    "B ∈∘ Vset α"
  show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J'. 𝔄 i) a b) ∈∘ Vset α"
  proof-
    from prems(1) assms have "J' ⊆∘ I" by simp
    from pdg_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
  qed
qed (rule pdg_vsubset_index_pdigraph_base[OF assms])


subsubsection‹A product ‹α›-digraph is an ‹α›-digraph›

lemma (in pdigraph) pdg_digraph_dg_prod: "digraph α (∏DGi∈∘I. 𝔄 i)"
proof-
  interpret tiny_digraph ‹α + ω› ‹∏DGi∈∘I. 𝔄 i›
    by (intro pdg_tiny_digraph_dg_prod) 
      (auto simp: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
  show ?thesis
    by (rule digraph_if_digraph)  
      (
        auto 
          intro!: pdg_Hom_vifunion_in_Vset pdg_Obj_vsubset_Vset
          intro: dg_cs_intros
      )
qed



subsection‹Local assumptions for a finite product digraph›


subsubsection‹Definition and elementary properties›

locale finite_pdigraph = pdigraph_base α I 𝔄 for α I 𝔄 +
  assumes fin_pdg_index_vfinite: "vfinite I"


text‹Rules.›

lemma (in finite_pdigraph) finite_pdigraph_axioms'[dg_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "finite_pdigraph α' I' 𝔄"
  unfolding assms by (rule finite_pdigraph_axioms)

mk_ide rf finite_pdigraph_def[unfolded finite_pdigraph_axioms_def]
  |intro finite_pdigraphI|
  |dest finite_pdigraphD[dest]|
  |elim finite_pdigraphE[elim]|

lemmas [dg_prod_cs_intros] = finite_pdigraphD(1)


subsubsection‹
Local assumptions for a finite product digraph and local
assumptions for an arbitrary product digraph
›

sublocale finite_pdigraph ⊆ pdigraph α I 𝔄
proof(intro pdigraphI)
  show "(∏DGi∈∘J. 𝔄 i)⦇Obj⦈ ⊆∘ Vset α" if "J ⊆∘ I" for J
    unfolding dg_prod_components
  proof-
    from that fin_pdg_index_vfinite have J: "vfinite J"
      by (cs_concl cs_intro: vfinite_vsubset)
    show "(∏∘i∈∘J. 𝔄 i⦇Obj⦈) ⊆∘ Vset α"
    proof(intro vsubsetI)
      fix A assume prems: "A ∈∘ (∏∘i∈∘J. 𝔄 i⦇Obj⦈)"
      note A = vproductD[OF prems, rule_format]
      show "A ∈∘ Vset α"
      proof(rule vsv.vsv_Limit_vsv_in_VsetI)
        from that show "𝒟∘ A ∈∘ Vset α" 
          unfolding A(2) by (auto intro: pdg_index_in_Vset)
        show "ℛ∘ A ⊆∘ Vset α"
        proof(intro vsv.vsv_vrange_vsubset, unfold A(2))
          fix i assume prems': "i ∈∘ J"
          with that have i: "i ∈∘ I" by auto
          interpret digraph α ‹𝔄 i›
            by (cs_concl cs_intro: dg_prod_cs_intros i)
          have "A⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈" by (rule A(3)[OF prems'])
          then show "A⦇i⦈ ∈∘ Vset α" by (cs_concl cs_intro: dg_cs_intros)
        qed (intro A(1))
      qed (auto simp: A(2) intro!: J A(1))
    qed
  qed
  show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J. 𝔄 i) a b) ∈∘ Vset α"
    if J: "J ⊆∘ I"
      and A: "A ⊆∘ (∏DGi∈∘J. 𝔄 i)⦇Obj⦈"
      and B: "B ⊆∘ (∏DGi∈∘J. 𝔄 i)⦇Obj⦈"
      and A_in_Vset: "A ∈∘ Vset α"
      and B_in_Vset: "B ∈∘ Vset α"
    for J A B 
  proof-
    interpret J: pdigraph_base α J 𝔄 
      by (intro J pdg_vsubset_index_pdigraph_base)
    let ?UA = ‹⋃∘(⋃∘(⋃∘A))› and ?UB = ‹⋃∘(⋃∘(⋃∘B))›
    from that(4) have UA: "?UA ∈∘ Vset α" by (intro VUnion_in_VsetI)
    from that(5) have UB: "?UB ∈∘ Vset α" by (intro VUnion_in_VsetI)
    have "(∏∘i∈∘J. (⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b)) ∈∘ Vset α"
    proof(intro Limit_vproduct_in_VsetI)
      from that(1) show "J ∈∘ Vset α" by (auto intro!: pdg_index_in_Vset)
      show "(⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b) ∈∘ Vset α" if i: "i ∈∘ J" for i
      proof-
        from i J have i: "i ∈∘ I" by auto
        interpret digraph α ‹𝔄 i› 
          using i by (cs_concl cs_intro: dg_prod_cs_intros)
        have [dg_cs_simps]: "(⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b) ⊆∘
          (⋃∘a∈∘?UA ∩∘ 𝔄 i⦇Obj⦈. ⋃∘b∈∘?UB ∩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b)"
        proof(intro vsubsetI)
          fix f assume "f ∈∘ (⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b)"
          then obtain a b
            where a: "a ∈∘ ?UA" and b: "b ∈∘ ?UB" and f: "f : a ↦𝔄 i b" 
            by (elim vifunionE, unfold in_Hom_iff)
          then show
            "f ∈∘ (⋃∘a∈∘?UA ∩∘ 𝔄 i⦇Obj⦈. ⋃∘b∈∘?UB ∩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b)"
            by (intro vifunionI, unfold in_Hom_iff) (auto intro!: f b a)
        qed
        moreover from UA UB have 
          "(⋃∘a∈∘?UA ∩∘ 𝔄 i⦇Obj⦈. ⋃∘b∈∘?UB ∩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b) ∈∘ 
            Vset α"
          by (intro dg_Hom_vifunion_in_Vset) auto
        ultimately show ?thesis by auto
      qed
      from J show "vfinite J"
        by (rule vfinite_vsubset[OF fin_pdg_index_vfinite])
    qed auto
    moreover have 
      "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J. 𝔄 i) a b) ⊆∘
        (∏∘i∈∘J. (⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b))"
    proof(intro vsubsetI)
      fix f assume "f ∈∘ (⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J. 𝔄 i) a b)"
      then obtain a b 
        where a: "a ∈∘ A" and b: "b ∈∘ B" and f: "f ∈∘ Hom (∏DGi∈∘J. 𝔄 i) a b"
        by auto
      from f have f: "f : a ↦(∏DGi∈∘J. 𝔄 i) b" by simp
      show "f ∈∘ (∏∘i∈∘J. (⋃∘a∈∘?UA. ⋃∘b∈∘?UB. Hom (𝔄 i) a b))"
      proof
        (
          intro vproductI, 
          unfold Ball_def; 
          (intro allI impI)?;
          (intro vifunionI)?;
          (unfold in_Hom_iff)?
        )
        from f show "vsv f" by (auto simp: dg_prod_components(2))
        from f show "𝒟∘ f = J" by (auto simp: dg_prod_components(2))
        fix i assume i: "i ∈∘ J"
        show "a⦇i⦈ ∈∘ ?UA"
          by 
            (
              intro vprojection_in_VUnionI, 
              rule that(2)[unfolded dg_prod_components(1)]; 
              intro a i
            )
        show "b⦇i⦈ ∈∘ ?UB"
          by 
            (
              intro vprojection_in_VUnionI, 
              rule that(3)[unfolded dg_prod_components(1)]; 
              intro b i
            )
        show "f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈" by (rule J.dg_prod_is_arrD(7)[OF f i])
      qed
    qed
    ultimately show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏DGi∈∘J. 𝔄 i) a b) ∈∘ Vset α" 
      by blast
  qed
qed (intro pdigraph_base_axioms)



subsection‹Binary union and complement›


subsubsection‹Application-specific methods›

method vdiff_of_vunion uses rule assms subset = 
  (
    rule 
      rule
        [
          OF vintersection_complement assms, 
          unfolded vunion_complement[OF subset]
        ]
  )

method vdiff_of_vunion' uses rule assms subset = 
  (
    rule 
      rule
        [
          OF vintersection_complement complement_vsubset subset assms, 
          unfolded vunion_complement[OF subset]
        ]
  )


subsubsection‹Results›

lemma dg_prod_vunion_Obj_in_Obj:
  assumes "vdisjnt J K"
    and "b ∈∘ (∏DGj∈∘J. 𝔄 j)⦇Obj⦈" 
    and "c ∈∘ (∏DGk∈∘K. 𝔄 k)⦇Obj⦈"
  shows "b ∪∘ c ∈∘ (∏DGi∈∘J ∪∘ K. 𝔄 i)⦇Obj⦈"
proof-

  interpret b: vsv b using assms(2) unfolding dg_prod_components by clarsimp
  interpret c: vsv c using assms(3) unfolding dg_prod_components by clarsimp

  from assms(2,3) have dom_b: "𝒟∘ b = J" and dom_c: "𝒟∘ c = K"
    unfolding dg_prod_components by auto
  from assms(1) have disjnt: "𝒟∘ b ∩∘ 𝒟∘ c = 0" unfolding dom_b dom_c by auto

  show ?thesis
    unfolding dg_prod_components
  proof(intro vproductI)
    show "𝒟∘ (b ∪∘ c) = J ∪∘ K" by (auto simp: vdomain_vunion dom_b dom_c)
    show "∀i∈∘J ∪∘ K. (b ∪∘ c)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
    proof(intro ballI)
      fix i assume prems: "i ∈∘ J ∪∘ K" 
      then consider (ib) ‹i ∈∘ 𝒟∘ b› | (ic) ‹i ∈∘ 𝒟∘ c› 
        unfolding dom_b dom_c by auto
      then show "(b ∪∘ c)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
      proof cases
        case ib
        with prems disjnt have bc_i: "(b ∪∘ c)⦇i⦈ = b⦇i⦈"
          by (auto intro!: vsv_vunion_app_left)
        from assms(2) ib show ?thesis unfolding bc_i dg_prod_components by auto
      next
        case ic 
        with prems disjnt have bc_i: "(b ∪∘ c)⦇i⦈ = c⦇i⦈"
          by (auto intro!: vsv_vunion_app_right)
        from assms(3) ic show ?thesis unfolding bc_i dg_prod_components by auto
      qed 
    qed
  qed (auto simp: disjnt)

qed

lemma dg_prod_vdiff_vunion_Obj_in_Obj:
  assumes "J ⊆∘ I"
    and "b ∈∘ (∏DGk∈∘I -∘ J. 𝔄 k)⦇Obj⦈" 
    and "c ∈∘ (∏DGj∈∘J. 𝔄 j)⦇Obj⦈"
  shows "b ∪∘ c ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
  by 
    (
      vdiff_of_vunion 
        rule: dg_prod_vunion_Obj_in_Obj assms: assms(2,3) subset: assms(1)
    )

lemma dg_prod_vunion_Arr_in_Arr:
  assumes "vdisjnt J K" 
    and "b ∈∘ (∏DGj∈∘J. 𝔄 j)⦇Arr⦈" 
    and "c ∈∘ (∏DGk∈∘K. 𝔄 k)⦇Arr⦈"
  shows "b ∪∘ c ∈∘ (∏DGi∈∘J ∪∘ K. 𝔄 i)⦇Arr⦈"
  unfolding dg_prod_components
proof(intro vproductI)

  interpret b: vsv b using assms(2) unfolding dg_prod_components by clarsimp
  interpret c: vsv c using assms(3) unfolding dg_prod_components by clarsimp

  from assms have dom_b: "𝒟∘ b = J" and dom_c: "𝒟∘ c = K" 
    unfolding dg_prod_components by auto
  from assms have disjnt: "𝒟∘ b ∩∘ 𝒟∘ c = 0" unfolding dom_b dom_c by auto

  from disjnt show "vsv (b ∪∘ c)" by auto
  show dom_bc: "𝒟∘ (b ∪∘ c) = J ∪∘ K" 
    unfolding vdomain_vunion dom_b dom_c by auto

  show "∀i∈∘J ∪∘ K. (b ∪∘ c)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
  proof(intro ballI)
    fix i assume prems: "i ∈∘ J ∪∘ K" 
    then consider (ib) ‹i ∈∘ 𝒟∘ b› | (ic) ‹i ∈∘ 𝒟∘ c› 
      unfolding dom_b dom_c by auto
    then show "(b ∪∘ c)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
    proof cases
      case ib
      with prems disjnt have bc_i: "(b ∪∘ c)⦇i⦈ = b⦇i⦈"
        by (auto intro!: vsv_vunion_app_left)
      from assms(2) ib show ?thesis unfolding bc_i dg_prod_components by auto
    next
      case ic 
      with prems disjnt have bc_i: "(b ∪∘ c)⦇i⦈ = c⦇i⦈"
        by (auto intro!: vsv_vunion_app_right)
      from assms(3) ic show ?thesis unfolding bc_i dg_prod_components by auto
    qed 
  qed

qed

lemma dg_prod_vdiff_vunion_Arr_in_Arr:
  assumes "J ⊆∘ I"
    and "b ∈∘ (∏DGk∈∘I -∘ J. 𝔄 k)⦇Arr⦈" 
    and "c ∈∘ (∏DGj∈∘J. 𝔄 j)⦇Arr⦈"
  shows "b ∪∘ c ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
  by 
    (
      vdiff_of_vunion 
        rule: dg_prod_vunion_Arr_in_Arr assms: assms(2,3) subset: assms(1)
    )

lemma (in pdigraph) pdg_dg_prod_vunion_is_arr:
  assumes "vdisjnt J K"
    and "J ⊆∘ I"
    and "K ⊆∘ I"
    and "g : a ↦(∏DGj∈∘J. 𝔄 j) b" 
    and "f : c ↦(∏DGk∈∘K. 𝔄 k) d"
  shows "g ∪∘ f : a ∪∘ c ↦(∏DGi∈∘J ∪∘ K. 𝔄 i) b ∪∘ d"
proof-

  interpret J𝔄: pdigraph α J 𝔄 
    using assms(2) by (simp add: pdg_vsubset_index_pdigraph)
  interpret K𝔄: pdigraph α K 𝔄 
    using assms(3) by (simp add: pdg_vsubset_index_pdigraph)
  interpret JK𝔄: pdigraph α ‹J ∪∘ K› 𝔄 
    using assms(2,3) by (simp add: pdg_vsubset_index_pdigraph)

  show ?thesis
  proof(intro JK𝔄.dg_prod_is_arrI)

    note gD = J𝔄.dg_prod_is_arrD[OF assms(4)]
      and fD = K𝔄.dg_prod_is_arrD[OF assms(5)]

    from assms(1) gD fD show
      "vsv (g ∪∘ f)"
      "𝒟∘ (g ∪∘ f) = J ∪∘ K"
      "vsv (a ∪∘ c)"
      "𝒟∘ (a ∪∘ c) = J ∪∘ K"
      "vsv (b ∪∘ d)" 
      "𝒟∘ (b ∪∘ d) = J ∪∘ K"
      by (auto simp: vdomain_vunion)

    fix i assume "i ∈∘ J ∪∘ K"
    then consider (iJ) ‹i ∈∘ J› | (iK) ‹i ∈∘ K› by auto
    then show "(g ∪∘ f)⦇i⦈ : (a ∪∘ c)⦇i⦈ ↦𝔄 i (b ∪∘ d)⦇i⦈" 
    proof cases
      case iJ
      have gf_i: "(g ∪∘ f)⦇i⦈ = g⦇i⦈" by (simp add: iJ assms(1) gD(1,2) fD(1,2))        
      have ac_i: "(a ∪∘ c)⦇i⦈ = a⦇i⦈" by (simp add: iJ assms(1) gD(3,4) fD(3,4))
      have bd_i: "(b ∪∘ d)⦇i⦈ = b⦇i⦈" by (simp add: iJ assms(1) gD(5,6) fD(5,6))
      show ?thesis unfolding gf_i ac_i bd_i by (rule gD(7)[OF iJ])
    next
      case iK
      have gf_i: "(g ∪∘ f)⦇i⦈ = f⦇i⦈" by (simp add: iK assms(1) gD(1,2) fD(1,2))        
      have ac_i: "(a ∪∘ c)⦇i⦈ = c⦇i⦈" by (simp add: iK assms(1) gD(3,4) fD(3,4))
      have bd_i: "(b ∪∘ d)⦇i⦈ = d⦇i⦈" by (simp add: iK assms(1) gD(5,6) fD(5,6))
      show ?thesis unfolding gf_i ac_i bd_i by (rule fD(7)[OF iK])
    qed

  qed

qed

lemma (in pdigraph) pdg_dg_prod_vdiff_vunion_is_arr:
  assumes "J ⊆∘ I"  
    and "g : a ↦(∏DGk∈∘I -∘ J. 𝔄 k) b" 
    and "f : c ↦(∏DGj∈∘J. 𝔄 j) d"
  shows "g ∪∘ f : a ∪∘ c ↦∏DGi∈∘I. 𝔄 i b ∪∘ d"
  by 
    (
      vdiff_of_vunion' 
        rule: pdg_dg_prod_vunion_is_arr assms: assms(2,3) subset: assms(1)
    )



subsection‹Projection›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›

definition dghm_proj :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V" (‹πDG›)
  where "πDG I 𝔄 i =
    [
      (λa∈∘((∏DGi∈∘I. 𝔄 i)⦇Obj⦈). a⦇i⦈),
      (λf∈∘((∏DGi∈∘I. 𝔄 i)⦇Arr⦈). f⦇i⦈),
      (∏DGi∈∘I. 𝔄 i),
      𝔄 i
    ]∘"


text‹Components.›

lemma dghm_proj_components:
  shows "πDG I 𝔄 i⦇ObjMap⦈ = (λa∈∘((∏DGi∈∘I. 𝔄 i)⦇Obj⦈). a⦇i⦈)"
    and "πDG I 𝔄 i⦇ArrMap⦈ = (λf∈∘((∏DGi∈∘I. 𝔄 i)⦇Arr⦈). f⦇i⦈)"
    and "πDG I 𝔄 i⦇HomDom⦈ = (∏DGi∈∘I. 𝔄 i)"
    and "πDG I 𝔄 i⦇HomCod⦈ = 𝔄 i"
  unfolding dghm_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Object map.›

mk_VLambda dghm_proj_components(1)
  |vsv dghm_proj_ObjMap_vsv[dg_cs_intros]|
  |vdomain dghm_proj_ObjMap_vdomain[dg_cs_simps]|
  |app dghm_proj_ObjMap_app[dg_cs_simps]|

lemma (in pdigraph) dghm_proj_ObjMap_vrange: 
  assumes "i ∈∘ I"
  shows "ℛ∘ (πDG I 𝔄 i⦇ObjMap⦈) ⊆∘ 𝔄 i⦇Obj⦈"
  using assms 
  unfolding dghm_proj_components
  by (intro vrange_VLambda_vsubset) (clarsimp simp: dg_prod_components)


text‹Arrow map.›

mk_VLambda dghm_proj_components(2)
  |vsv dghm_proj_ArrMap_vsv[dg_cs_intros]|
  |vdomain dghm_proj_ArrMap_vdomain[dg_cs_simps]|
  |app dghm_proj_ArrMap_app[dg_cs_simps]|

lemma (in pdigraph) dghm_proj_ArrMap_vrange: 
  assumes "i ∈∘ I"
  shows "ℛ∘ (πDG I 𝔄 i⦇ArrMap⦈) ⊆∘ 𝔄 i⦇Arr⦈"
  using assms 
  unfolding dghm_proj_components
  by (intro vrange_VLambda_vsubset) (clarsimp simp: dg_prod_components)


subsubsection‹A projection digraph homomorphism is a digraph homomorphism›

lemma (in pdigraph) pdg_dghm_proj_is_dghm: 
  assumes "i ∈∘ I" 
  shows "πDG I 𝔄 i : (∏DGi∈∘I. 𝔄 i) ↦↦DGα 𝔄 i"
proof(intro is_dghmI)
  show "vfsequence (πDG I 𝔄 i)" unfolding dghm_proj_def by auto
  show "vcard (πDG I 𝔄 i) = 4ℕ"
    unfolding dghm_proj_def by (simp add: nat_omega_simps)
  show "πDG I 𝔄 i⦇HomDom⦈ = (∏DGi∈∘I. 𝔄 i)"
    unfolding dghm_proj_components by simp
  show "πDG I 𝔄 i⦇HomCod⦈ = 𝔄 i" 
    unfolding dghm_proj_components by simp
  fix f a b assume "f : a ↦∏DGi∈∘I. 𝔄 i b"
  with assms pdg_digraph_dg_prod show 
    "πDG I 𝔄 i⦇ArrMap⦈⦇f⦈ : πDG I 𝔄 i⦇ObjMap⦈⦇a⦈ ↦𝔄 i πDG I 𝔄 i⦇ObjMap⦈⦇b⦈"
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_is_arrD(7))
qed 
  (
    auto simp: 
      dg_cs_simps dg_cs_intros dg_prod_cs_intros
      assms pdg_digraph_dg_prod dghm_proj_ObjMap_vrange
  )

lemma (in pdigraph) pdg_dghm_proj_is_dghm':
  assumes "i ∈∘ I" and "ℭ = (∏DGi∈∘I. 𝔄 i)" and "𝔇 = 𝔄 i"
  shows "πDG I 𝔄 i : ℭ ↦↦DGα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule pdg_dghm_proj_is_dghm)

lemmas [dg_cs_intros] = pdigraph.pdg_dghm_proj_is_dghm'



subsection‹Digraph product universal property digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹
The following digraph homomorphism is used in the 
proof of the universal property of the product digraph 
later in this work.
›

definition dghm_up :: "V ⇒ (V ⇒ V) ⇒ V ⇒ (V ⇒ V) ⇒ V"
  where "dghm_up I 𝔄 ℭ φ =
    [
      (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈)),
      (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈)),
      ℭ,
      (∏DGi∈∘I. 𝔄 i)
    ]∘"


text‹Components.›

lemma dghm_up_components: 
  shows "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈))"
    and "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈))"
    and "dghm_up I 𝔄 ℭ φ⦇HomDom⦈ = ℭ"
    and "dghm_up I 𝔄 ℭ φ⦇HomCod⦈ = (∏DGi∈∘I. 𝔄 i)"
  unfolding dghm_up_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_up_components(1)
  |vsv dghm_up_ObjMap_vsv[dg_cs_intros]|
  |vdomain dghm_up_ObjMap_vdomain[dg_cs_simps]|
  |app dghm_up_ObjMap_app|

lemma dghm_up_ObjMap_vrange: 
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
  unfolding dghm_up_components dg_prod_components
proof(intro vrange_VLambda_vsubset vproductI)
  fix a assume prems: "a ∈∘ ℭ⦇Obj⦈"
  show "∀i∈∘I. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈"
  proof(intro ballI)
    fix i assume prems': "i ∈∘ I"
    interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems'])
    from prems prems' show "(λi∈∘I. φ i⦇ObjMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Obj⦈" 
      by (simp add: φ.dghm_ObjMap_app_in_HomCod_Obj)
  qed
qed auto

lemma dghm_up_ObjMap_app_vdomain[dg_cs_simps]: 
  assumes "a ∈∘ ℭ⦇Obj⦈"
  shows "𝒟∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) = I"
  unfolding dghm_up_ObjMap_app[OF assms] by simp

lemma dghm_up_ObjMap_app_component[dg_cs_simps]: 
  assumes "a ∈∘ ℭ⦇Obj⦈" and "i ∈∘ I"
  shows "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ = φ i⦇ObjMap⦈⦇a⦈"
  using assms unfolding dghm_up_components by simp

lemma dghm_up_ObjMap_app_vrange: 
  assumes "a ∈∘ ℭ⦇Obj⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Obj⦈)"
proof(intro vsubsetI)
  fix b assume prems: "b ∈∘ ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈)"
  have "vsv (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈)"
    unfolding dghm_up_ObjMap_app[OF assms(1)] by auto
  with prems obtain i where b_def: "b = dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈" 
    and i: "i ∈∘ I"
    by (auto elim: vsv.vrange_atE simp: dghm_up_ObjMap_app[OF assms(1)])
  interpret φi: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF i])
  from dghm_up_ObjMap_app_component[OF assms(1) i] b_def have b_def':
    "b = φ i⦇ObjMap⦈⦇a⦈"
    by simp
  from assms(1) have "b ∈∘ 𝔄 i⦇Obj⦈" 
    unfolding b_def' by (auto intro: dg_cs_intros)
  with i show "b ∈∘ (⋃∘i∈∘I. 𝔄 i⦇Obj⦈)" by force
qed


subsubsection‹Arrow map›

mk_VLambda dghm_up_components(2)
  |vsv dghm_up_ArrMap_vsv[dg_cs_intros]|
  |vdomain dghm_up_ArrMap_vdomain[dg_cs_simps]|
  |app dghm_up_ArrMap_app|

lemma (in pdigraph) dghm_up_ArrMap_vrange: 
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
  unfolding dghm_up_components dg_prod_components
proof(intro vrange_VLambda_vsubset vproductI)
  fix a assume prems: "a ∈∘ ℭ⦇Arr⦈"
  show "∀i∈∘I. (λi∈∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
  proof(intro ballI)
    fix i assume prems': "i ∈∘ I"
    interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems'])
    from prems prems' show "(λi∈∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈" 
      by (auto intro: dg_cs_intros)
  qed
qed auto

lemma dghm_up_ArrMap_vrange: 
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
proof(intro vsubsetI)
  fix A assume "A ∈∘ ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈)"
  then obtain a where A_def: "A = dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈" 
    and a: "a ∈∘ ℭ⦇Arr⦈"
    unfolding dghm_up_ArrMap_vdomain dghm_up_components by auto
  have "(λi∈∘I. φ i⦇ArrMap⦈⦇a⦈) ∈∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
  proof(intro vproductI)
    show "∀i∈∘I. (λi∈∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈"
    proof(intro ballI)
      fix i assume prems: "i ∈∘ I"
      interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems])
      from prems a show "(λi∈∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈" 
        by (auto intro: dg_cs_intros)
    qed
  qed simp_all
  with a show "A ∈∘ (∏DGi∈∘I. 𝔄 i)⦇Arr⦈"
    unfolding A_def dg_prod_components dghm_up_components by simp
qed

lemma dghm_up_ArrMap_app_vdomain[dg_cs_simps]: 
  assumes "a ∈∘ ℭ⦇Arr⦈"
  shows "𝒟∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) = I"
  unfolding dghm_up_ArrMap_app[OF assms] by simp

lemma dghm_up_ArrMap_app_component[dg_cs_simps]: 
  assumes "a ∈∘ ℭ⦇Arr⦈" and "i ∈∘ I"
  shows "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈ = φ i⦇ArrMap⦈⦇a⦈"
  using assms unfolding dghm_up_components by simp

lemma dghm_up_ArrMap_app_vrange: 
  assumes "a ∈∘ ℭ⦇Arr⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Arr⦈)"
proof(intro vsubsetI)
  fix b assume prems: "b ∈∘ ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈)"
  have "vsv (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈)"
    unfolding dghm_up_ArrMap_app[OF assms(1)] by auto
  with prems obtain i where b_def: "b = dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈" 
    and i: "i ∈∘ I"
    by (auto elim: vsv.vrange_atE simp: dghm_up_ArrMap_app[OF assms(1)])
  interpret φi: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF i])
  from dghm_up_ArrMap_app_component[OF assms(1) i] b_def have b_def':
    "b = φ i⦇ArrMap⦈⦇a⦈"
    by simp
  from assms(1) have "b ∈∘ 𝔄 i⦇Arr⦈" 
    unfolding b_def' by (auto intro: dg_cs_intros)
  with i show "b ∈∘ (⋃∘i∈∘I. 𝔄 i⦇Arr⦈)" by force
qed


subsubsection‹
Digraph product universal property 
digraph homomorphism is a digraph homomorphism
›

lemma (in pdigraph) pdg_dghm_up_is_dghm:
  assumes "digraph α ℭ" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i"
  shows "dghm_up I 𝔄 ℭ φ : ℭ ↦↦DGα (∏DGi∈∘I. 𝔄 i)"
proof-
  interpret ℭ: digraph α ℭ by (rule assms(1))
  show ?thesis
  proof(intro is_dghmI, unfold dghm_up_components(3,4))
    show "vfsequence (dghm_up I 𝔄 ℭ φ)" unfolding dghm_up_def by simp
    show "vcard (dghm_up I 𝔄 ℭ φ) = 4ℕ"
      unfolding dghm_up_def by (simp add: nat_omega_simps)
    from assms(2) show "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆∘ (∏DGi∈∘I. 𝔄 i)⦇Obj⦈"
      by (intro dghm_up_ObjMap_vrange) blast
    fix f a b assume prems: "f : a ↦ℭ b"
    then have f: "f ∈∘ ℭ⦇Arr⦈" and a: "a ∈∘ ℭ⦇Obj⦈" and b: "b ∈∘ ℭ⦇Obj⦈" by auto
    show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈ :
      dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈ ↦∏DGi∈∘I. 𝔄 i dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇b⦈"
    proof(rule dg_prod_is_arrI)
      fix i assume prems': "i ∈∘ I"
      interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF prems'])
      from φ.is_dghm_axioms ℭ.digraph_axioms prems pdigraph_axioms prems prems' 
      show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈⦇i⦈ : 
        dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ ↦𝔄 i dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇b⦈⦇i⦈"
        by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
    qed (simp_all add: f a b dghm_up_ArrMap_app dghm_up_ObjMap_app)
  qed (auto simp: dghm_up_components pdg_digraph_dg_prod dg_cs_intros)
qed


subsubsection‹Further properties›

lemma (in pdigraph) pdg_dghm_comp_dghm_proj_dghm_up: 
  assumes "digraph α ℭ"
    and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦DGα 𝔄 i" 
    and "i ∈∘ I" 
  shows "φ i = πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ"
proof(rule dghm_eqI[of α ℭ ‹𝔄 i› _ ℭ ‹𝔄 i›])
  
  interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF assms(3)])
  
  show "φ i : ℭ ↦↦DGα 𝔄 i" by (auto intro: dg_cs_intros)

  from assms(1,2) have dghm_up: "dghm_up I 𝔄 ℭ φ : ℭ ↦↦DGα (∏DGi∈∘I. 𝔄 i)"
    by (simp add: pdg_dghm_up_is_dghm)
  note dghm_proj = pdg_dghm_proj_is_dghm[OF assms(3)]

  from assms(3) pdg_dghm_proj_is_dghm show
    "πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ : ℭ ↦↦DGα 𝔄 i"
    by (intro dghm_comp_is_dghm[of α ‹(∏DGi∈∘I. 𝔄 i)›]) 
      (auto simp: assms dghm_up)
  
  show "φ i⦇ObjMap⦈ = (πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈"
  proof(rule vsv_eqI)
    show "vsv ((πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈)"
      unfolding dghm_comp_components dghm_proj_components dghm_up_components 
      by (rule vsv_vcomp) simp_all
    from 
      dghm_up_ObjMap_vrange[
        OF assms(2), simplified, unfolded dg_prod_components
        ]
    have rd: "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆∘ 𝒟∘ (πDG I 𝔄 i⦇ObjMap⦈)"
      by (simp add: dg_prod_components dg_cs_simps)
    show "𝒟∘ (φ i⦇ObjMap⦈) = 𝒟∘ ((πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈)"
      unfolding dghm_comp_components vdomain_vcomp_vsubset[OF rd] 
      by (simp add: dg_cs_simps)
    fix a assume "a ∈∘ 𝒟∘ (φ i⦇ObjMap⦈)"
    then have a: "a ∈∘ ℭ⦇Obj⦈" by (simp add: dg_cs_simps) 
    with dghm_up dghm_proj assms(3) show 
      "φ i⦇ObjMap⦈⦇a⦈ = (πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈⦇a⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed auto

  show "φ i⦇ArrMap⦈ = (πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈"
  proof(rule vsv_eqI)
    show "vsv ((πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈)"
      unfolding dghm_comp_components dghm_proj_components dghm_up_components 
      by (rule vsv_vcomp) simp_all
    from 
      dghm_up_ArrMap_vrange[
        OF assms(2), simplified, unfolded dg_prod_components
        ]
    have rd: "ℛ∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆∘ 𝒟∘ (πDG I 𝔄 i⦇ArrMap⦈)"
      by (simp add: dg_prod_components dg_cs_simps)
    show "𝒟∘ (φ i⦇ArrMap⦈) = 𝒟∘ ((πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈)"
      unfolding dghm_comp_components vdomain_vcomp_vsubset[OF rd] 
      by (simp add: dg_cs_simps)
    fix a assume "a ∈∘ 𝒟∘ (φ i⦇ArrMap⦈)"
    then have a: "a ∈∘ ℭ⦇Arr⦈" by (simp add: dg_cs_simps)
    with dghm_up dghm_proj assms(3) show 
      "φ i⦇ArrMap⦈⦇a⦈ = (πDG I 𝔄 i ∘DGHM dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈⦇a⦈"
      by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
  qed auto

qed simp_all
      
lemma (in pdigraph) pdg_dghm_up_eq_dghm_proj:
  assumes "𝔉 : ℭ ↦↦DGα (∏DGi∈∘I. 𝔄 i)"
    and "⋀i. i ∈∘ I ⟹ φ i = πDG I 𝔄 i ∘DGHM 𝔉"
  shows "dghm_up I 𝔄 ℭ φ = 𝔉"
proof(rule dghm_eqI)

  interpret 𝔉: is_dghm α ℭ ‹(∏DGi∈∘I. 𝔄 i)› 𝔉 by (rule assms(1))

  show "dghm_up I 𝔄 ℭ φ : ℭ ↦↦DGα (∏DGi∈∘I. 𝔄 i)"
  proof(rule pdg_dghm_up_is_dghm)
    fix i assume prems: "i ∈∘ I"
    interpret π: is_dghm α ‹(∏DGi∈∘I. 𝔄 i)› ‹𝔄 i› ‹πDG I 𝔄 i›
      using prems by (rule pdg_dghm_proj_is_dghm)
    show "φ i : ℭ ↦↦DGα 𝔄 i" 
      unfolding assms(2)[OF prems] by (auto intro: dg_cs_intros)
  qed (auto intro: dg_cs_intros)

  show "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
  proof(rule vsv_eqI, unfold dghm_up_ObjMap_vdomain)
    fix a assume prems: "a ∈∘ ℭ⦇Obj⦈"
    show "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
    proof(rule vsv_eqI, unfold dghm_up_ObjMap_app_vdomain[OF prems])
      fix i assume prems': "i ∈∘ I"
      with pdg_dghm_proj_is_dghm[OF prems'] 𝔉.is_dghm_axioms prems show 
        "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ = 𝔉⦇ObjMap⦈⦇a⦈⦇i⦈"
        by (cs_concl cs_simp: dg_cs_simps assms(2) cs_intro: dg_cs_intros)
    qed 
      (
        use 𝔉.dghm_ObjMap_app_in_HomCod_Obj prems in 
          ‹auto simp: dg_prod_components dghm_up_ObjMap_app›
      )
  qed (auto simp: dghm_up_components dg_cs_simps)

  show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
  proof(rule vsv_eqI, unfold dghm_up_ArrMap_vdomain)
    fix a assume prems: "a ∈∘ ℭ⦇Arr⦈"
    show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
    proof(rule vsv_eqI, unfold dghm_up_ArrMap_app_vdomain[OF prems])
      fix i assume prems': "i ∈∘ I"
      with pdg_dghm_proj_is_dghm[OF prems'] 𝔉.is_dghm_axioms prems show 
        "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈ = 𝔉⦇ArrMap⦈⦇a⦈⦇i⦈"
        by (cs_concl cs_simp: dg_cs_simps assms(2) cs_intro: dg_cs_intros)
    qed 
      (
        use 𝔉.dghm_ArrMap_app_in_HomCod_Arr prems in 
          ‹auto simp: dg_prod_components dghm_up_ArrMap_app›
      )+
  qed (auto simp: dghm_up_components dg_cs_simps)

qed (simp_all add: assms(1))



subsection‹Singleton digraph›


subsubsection‹Object›

lemma dg_singleton_ObjI: 
  assumes "A = set {⟨j, a⟩}" and "a ∈∘ ℭ⦇Obj⦈"
  shows "A ∈∘ (∏DGi∈∘set {j}. ℭ)⦇Obj⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_singleton_ObjE: 
  assumes "A ∈∘ (∏DGi∈∘set {j}. ℭ)⦇Obj⦈"
  obtains a where "A = set {⟨j, a⟩}" and "a ∈∘ ℭ⦇Obj⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_components], rule_format] 
  have "vsv A" and [simp]: "𝒟∘ A = set {j}" and Aj: "A⦇j⦈ ∈∘ ℭ⦇Obj⦈"
    by simp_all
  then interpret A: vsv A by simp
  from A.vsv_is_VLambda have "A = set {⟨j, A⦇j⦈⟩}" 
    by (auto simp: VLambda_vsingleton)
  with Aj show ?thesis using that by simp
qed


subsubsection‹Arrow›

lemma dg_singleton_ArrI: 
  assumes "F = set {⟨j, a⟩}" and "a ∈∘ ℭ⦇Arr⦈"
  shows "F ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Arr⦈"
  using assms unfolding dg_prod_components by auto

lemma dg_singleton_ArrE: 
  assumes "F ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Arr⦈"
  obtains a where "F = set {⟨j, a⟩}" and "a ∈∘ ℭ⦇Arr⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_components], rule_format] 
  have "vsv F" and [simp]: "𝒟∘ F = set {j}" and Fj: "F⦇j⦈ ∈∘ ℭ⦇Arr⦈"
    by simp_all
  then interpret F: vsv F by simp
  from F.vsv_is_VLambda have "F = set {⟨j, F⦇j⦈⟩}" 
    by (auto simp: VLambda_vsingleton)
  with Fj show ?thesis using that by simp
qed


subsubsection‹Singleton digraph is a digraph›

lemma (in digraph) dg_finite_pdigraph_dg_singleton: 
  assumes "j ∈∘ Vset α"
  shows "finite_pdigraph α (set {j}) (λi. ℭ)"
  by (intro finite_pdigraphI pdigraph_baseI)
    (auto simp: digraph_axioms Limit_vsingleton_in_VsetI assms)

lemma (in digraph) dg_digraph_dg_singleton:
  assumes "j ∈∘ Vset α"
  shows "digraph α (∏DGj∈∘set {j}. ℭ)"
proof-
  interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
    using assms by (rule dg_finite_pdigraph_dg_singleton)
  show ?thesis by (rule pdg_digraph_dg_prod)
qed


subsubsection‹Arrow with a domain and a codomain›

lemma (in digraph) dg_singleton_is_arrI:
  assumes "j ∈∘ Vset α" and "f : a ↦ℭ b"
  shows "set {⟨j, f⟩} : set {⟨j, a⟩} ↦(∏DGj∈∘set {j}. ℭ) set {⟨j, b⟩}"
proof-
  interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
    by (rule dg_finite_pdigraph_dg_singleton[OF assms(1)])
  from assms(2) show ?thesis by (intro dg_prod_is_arrI) auto
qed

lemma (in digraph) dg_singleton_is_arrD:
  assumes "set {⟨j, f⟩} : set {⟨j, a⟩} ↦(∏DGj∈∘set {j}. ℭ) set {⟨j, b⟩}" 
    and "j ∈∘ Vset α"
  shows "f : a ↦ℭ b"
proof-
  interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
    by (rule dg_finite_pdigraph_dg_singleton[OF assms(2)])
  from dg_prod_is_arrD(7)[OF assms(1)] show ?thesis by simp
qed

lemma (in digraph) dg_singleton_is_arrE:
  assumes "set {⟨j, f⟩} : set {⟨j, a⟩} ↦(∏DGj∈∘set {j}. ℭ) set {⟨j, b⟩}" 
    and "j ∈∘ Vset α"
  obtains "f : a ↦ℭ b"
  using assms dg_singleton_is_arrD by auto



subsection‹Singleton digraph homomorphism›

definition dghm_singleton :: "V ⇒ V ⇒ V"
  where "dghm_singleton j ℭ = 
    [
      (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩}), 
      (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩}), 
      ℭ,
      (∏DGj∈∘set {j}. ℭ)
    ]∘"


text‹Components.›

lemma dghm_singleton_components:
  shows "dghm_singleton j ℭ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩})"
    and "dghm_singleton j ℭ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩})"
    and "dghm_singleton j ℭ⦇HomDom⦈ = ℭ"
    and "dghm_singleton j ℭ⦇HomCod⦈ = (∏DGj∈∘set {j}. ℭ)"
  unfolding dghm_singleton_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_singleton_components(1)
  |vsv dghm_singleton_ObjMap_vsv[dg_cs_intros]|
  |vdomain dghm_singleton_ObjMap_vdomain[dg_cs_simps]|
  |app dghm_singleton_ObjMap_app[dg_prod_cs_simps]|

lemma dghm_singleton_ObjMap_vrange[dg_cs_simps]: 
  "ℛ∘ (dghm_singleton j ℭ⦇ObjMap⦈) = (∏DGj∈∘set {j}. ℭ)⦇Obj⦈"
proof(intro vsubset_antisym vsubsetI)
  fix A assume "A ∈∘ ℛ∘ (dghm_singleton j ℭ⦇ObjMap⦈)"
  then obtain a where A_def: "A = set {⟨j, a⟩}" and a: "a ∈∘ ℭ⦇Obj⦈" 
    unfolding dghm_singleton_components by auto
  then show "A ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Obj⦈"
    unfolding dg_prod_components by auto
next
  fix A assume "A ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Obj⦈" 
  from vproductD[OF this[unfolded dg_prod_components], rule_format] 
  have "vsv A"
    and [simp]: "𝒟∘ A = set {j}" 
    and Ai: "⋀i. i ∈∘ set {j} ⟹ A⦇i⦈ ∈∘ ℭ⦇Obj⦈"
    by auto
  then interpret A: vsv A by simp
  from Ai have "A⦇j⦈ ∈∘ ℭ⦇Obj⦈" using Ai by auto
  moreover with A.vsv_is_VLambda have "A = (λf∈∘ℭ⦇Obj⦈. set {⟨j, f⟩})⦇A⦇j⦈⦈"
    by (simp add: VLambda_vsingleton)
  ultimately show "A ∈∘ ℛ∘ (dghm_singleton j ℭ⦇ObjMap⦈)"
    unfolding dghm_singleton_components
    by 
      (
        metis 
          dghm_singleton_ObjMap_vdomain 
          dghm_singleton_ObjMap_vsv 
          dghm_singleton_components(1) 
          vsv.vsv_vimageI2
      )
qed


subsubsection‹Arrow map›

mk_VLambda dghm_singleton_components(2)
  |vsv dghm_singleton_ArrMap_vsv[dg_cs_intros]|
  |vdomain dghm_singleton_ArrMap_vdomain[dg_cs_simps]|
  |app dghm_singleton_ArrMap_app[dg_prod_cs_simps]|

lemma dghm_singleton_ArrMap_vrange[dg_cs_simps]: 
  "ℛ∘ (dghm_singleton j ℭ⦇ArrMap⦈) = (∏DGj∈∘set {j}. ℭ)⦇Arr⦈"
proof(intro vsubset_antisym vsubsetI)
  fix F assume "F ∈∘ ℛ∘ (dghm_singleton j ℭ⦇ArrMap⦈)"
  then obtain f where "F = set {⟨j, f⟩}" and "f ∈∘ ℭ⦇Arr⦈" 
    unfolding dghm_singleton_components by auto
  then show "F ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Arr⦈"
    unfolding dg_prod_components by auto
next
  fix F assume "F ∈∘ (∏DGj∈∘set {j}. ℭ)⦇Arr⦈" 
  from vproductD[OF this[unfolded dg_prod_components], rule_format] 
  have "vsv F"
    and [simp]: "𝒟∘ F = set {j}" 
    and Fi: "⋀i. i ∈∘ set {j} ⟹ F⦇i⦈ ∈∘ ℭ⦇Arr⦈"
    by auto
  then interpret F: vsv F by simp
  from Fi have "F⦇j⦈ ∈∘ ℭ⦇Arr⦈" using Fi by auto
  moreover with F.vsv_is_VLambda have "F = (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩})⦇F⦇j⦈⦈"
    by (simp add: VLambda_vsingleton)
  ultimately show "F ∈∘ ℛ∘ (dghm_singleton j ℭ⦇ArrMap⦈)"
    unfolding dghm_singleton_components
    by 
      (
        metis 
          dghm_singleton_ArrMap_vdomain 
          dghm_singleton_ArrMap_vsv 
          dghm_singleton_components(2) 
          vsv.vsv_vimageI2
      )
qed


subsubsection‹Singleton digraph homomorphism is an isomorphism of digraphs›

lemma (in digraph) dg_dghm_singleton_is_dghm:
  assumes "j ∈∘ Vset α"
  shows "dghm_singleton j ℭ : ℭ ↦↦DG.isoα (∏DGj∈∘set {j}. ℭ)"
proof-
  interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
    by (rule dg_finite_pdigraph_dg_singleton[OF assms])
  show ?thesis
  proof(intro is_iso_dghmI is_dghmI)
    show "vfsequence (dghm_singleton j ℭ)" unfolding dghm_singleton_def by simp
    show "vcard (dghm_singleton j ℭ) = 4ℕ"
      unfolding dghm_singleton_def by (simp add: nat_omega_simps)
    show "ℛ∘ (dghm_singleton j ℭ⦇ObjMap⦈) ⊆∘ (∏DGj∈∘set {j}. ℭ)⦇Obj⦈"
      by (simp add: dg_cs_simps)
    show "dghm_singleton j ℭ⦇ArrMap⦈⦇f⦈ :
      dghm_singleton j ℭ⦇ObjMap⦈⦇a⦈ ↦∏DGj∈∘set {j}. ℭ 
      dghm_singleton j ℭ⦇ObjMap⦈⦇b⦈"
      if "f : a ↦ℭ b" for f a b
      using that
    proof(intro dg_prod_is_arrI)
      fix k assume "k ∈∘ set {j}"
      then have k_def: "k = j" by simp
      from that show "dghm_singleton j ℭ⦇ArrMap⦈⦇f⦈⦇k⦈ :
        dghm_singleton j ℭ⦇ObjMap⦈⦇a⦈⦇k⦈ ↦ℭ dghm_singleton j ℭ⦇ObjMap⦈⦇b⦈⦇k⦈"
        by 
          (
            cs_concl 
              cs_simp: k_def V_cs_simps dg_cs_simps dg_prod_cs_simps
              cs_intro: dg_cs_intros
          )
    qed 
      (
        cs_concl 
          cs_simp: V_cs_simps dg_prod_cs_simps 
          cs_intro: V_cs_intros dg_cs_intros
      )+
    show "ℛ∘ (dghm_singleton j ℭ⦇ObjMap⦈) = (∏DGj∈∘set {j}. ℭ)⦇Obj⦈" 
      by (simp add: dg_cs_simps)
    show "ℛ∘ (dghm_singleton j ℭ⦇ArrMap⦈) = (∏DGj∈∘set {j}. ℭ)⦇Arr⦈" 
      by (simp add: dg_cs_simps)
  qed 
    (
      auto simp: 
        dg_cs_intros 
        dg_digraph_dg_singleton[OF assms] 
        dghm_singleton_components
    )
qed



subsection‹Product of two digraphs›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›

definition dg_prod_2 :: "V ⇒ V ⇒ V" (infixr ‹×DG› 80)
  where "𝔄 ×DG 𝔅 ≡ dg_prod (2ℕ) (if2 𝔄 𝔅)"


subsubsection‹Product of two digraphs is a digraph›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)

lemma finite_pdigraph_dg_prod_2: "finite_pdigraph α (2ℕ) (if2 𝔄 𝔅)"
proof(intro finite_pdigraphI pdigraph_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "2ℕ ∈∘ Vset α" by blast
  show "digraph α (i = 0 ? 𝔄 : 𝔅)" if "i ∈∘ 2ℕ" for i
    by (auto intro: dg_cs_intros)
qed auto

interpretation finite_pdigraph α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)

lemma digraph_dg_prod_2[dg_cs_intros]: "digraph α (𝔄 ×DG 𝔅)"
proof-
  show ?thesis unfolding dg_prod_2_def by (rule pdg_digraph_dg_prod)
qed

end


subsubsection‹Object›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dg_prod_2_ObjI:
  assumes "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "[a, b]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
  unfolding dg_prod_2_def dg_prod_components
proof(intro vproductI ballI)
  show "𝒟∘ [a, b]∘ = 2ℕ" by (simp add: nat_omega_simps two)
  fix i assume "i ∈∘ 2ℕ"
  then consider ‹i = 0› | ‹i = 1ℕ› unfolding two by auto 
  then show "[a, b]∘⦇i⦈ ∈∘ (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈"
    by cases (simp_all add: nat_omega_simps assms(1,2))
qed auto

lemma dg_prod_2_ObjI'[dg_prod_cs_intros]:
  assumes "ab = [a, b]∘" and "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈"
  shows "ab ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
  using assms(2,3) unfolding assms(1) by (rule dg_prod_2_ObjI)

lemma dg_prod_2_ObjE:
  assumes "ab ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
  obtains a b where "ab = [a, b]∘" and "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_2_def dg_prod_components]]
  have vsv_ab: "vsv ab"
    and dom_ab: "𝒟∘ ab = 2ℕ"
    and ab_app: "⋀i. i ∈∘ 2ℕ ⟹ ab⦇i⦈ ∈∘ (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈"
    by auto
  have dom_ab[simp]: "𝒟∘ ab = 2ℕ"
    unfolding dom_ab by (simp add: nat_omega_simps two)
  interpret vsv ab by (rule vsv_ab)
  have "ab = [vpfst ab, vpsnd ab]∘"
    by (rule vsv_vfsequence_two[symmetric]) auto
  moreover from ab_app[of 0] have "vpfst ab ∈∘ 𝔄⦇Obj⦈" by simp
  moreover from ab_app[of ‹1ℕ›] have "vpsnd ab ∈∘ 𝔅⦇Obj⦈" by simp
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Arrow›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dg_prod_2_ArrI:
  assumes "g ∈∘ 𝔄⦇Arr⦈" and "f ∈∘ 𝔅⦇Arr⦈"
  shows "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  unfolding dg_prod_2_def dg_prod_components
proof(intro vproductI ballI)
  show "𝒟∘ [g, f]∘ = 2ℕ" by (simp add: nat_omega_simps two)
  fix i assume "i ∈∘ 2ℕ"
  then consider ‹i = 0› | ‹i = 1ℕ› unfolding two by auto 
  then show "[g, f]∘⦇i⦈ ∈∘ (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈"
    by cases (simp_all add: nat_omega_simps assms(1,2))
qed auto

lemma dg_prod_2_ArrI'[dg_prod_cs_intros]:
  assumes "gf = [g, f]∘" and "g ∈∘ 𝔄⦇Arr⦈" and "f ∈∘ 𝔅⦇Arr⦈"
  shows "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  using assms(2,3) unfolding assms(1) by (rule dg_prod_2_ArrI)

lemma dg_prod_2_ArrE:
  assumes "gf ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  obtains g f where "gf = [g, f]∘" and "g ∈∘ 𝔄⦇Arr⦈" and "f ∈∘ 𝔅⦇Arr⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_2_def dg_prod_components]]
  have vsv_gf: "vsv gf"
    and dom_gf: "𝒟∘ gf = 2ℕ"
    and gf_app: "⋀i. i ∈∘ 2ℕ ⟹ gf⦇i⦈ ∈∘ (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈"
    by auto
  have dom_gf[simp]: "𝒟∘ gf = 2ℕ" unfolding dom_gf by (simp add: two)
  interpret vsv gf by (rule vsv_gf)
  have "gf = [vpfst gf, vpsnd gf]∘"
    by (rule vsv_vfsequence_two[symmetric]) auto
  moreover from gf_app[of 0] have "vpfst gf ∈∘ 𝔄⦇Arr⦈" by simp
  moreover from gf_app[of ‹1ℕ›] have "vpsnd gf ∈∘ 𝔅⦇Arr⦈" by simp
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Arrow with a domain and a codomain›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation finite_pdigraph α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)

lemma dg_prod_2_is_arrI:
  assumes "g : a ↦𝔄 c" and "f : b ↦𝔅 d"
  shows "[g, f]∘ : [a, b]∘ ↦𝔄 ×DG 𝔅 [c, d]∘"
  unfolding dg_prod_2_def
proof(rule dg_prod_is_arrI)
  show "[g, f]∘⦇i⦈ : [a, b]∘⦇i⦈ ↦if i = 0 then 𝔄 else 𝔅 [c, d]∘⦇i⦈"
    if "i ∈∘ 2ℕ" for i
  proof-
    from that consider ‹i = 0› | ‹i = 1ℕ› unfolding two by auto 
    then show "[g, f]∘⦇i⦈ : [a, b]∘⦇i⦈ ↦if i = 0 then 𝔄 else 𝔅 [c, d]∘⦇i⦈"
      by cases (simp_all add: nat_omega_simps assms)
  qed
qed (auto simp: nat_omega_simps two)

lemma dg_prod_2_is_arrI'[dg_prod_cs_intros]:
  assumes "gf = [g, f]∘"
    and "ab = [a, b]∘"
    and "cd = [c, d]∘"
    and "g : a ↦𝔄 c" 
    and "f : b ↦𝔅 d"
  shows "gf : ab ↦𝔄 ×DG 𝔅 cd"
  using assms(4,5) unfolding assms(1,2,3) by (rule dg_prod_2_is_arrI)

lemma dg_prod_2_is_arrE:
  assumes "gf : ab ↦𝔄 ×DG 𝔅 cd"
  obtains g f a b c d 
    where "gf = [g, f]∘"
      and "ab = [a, b]∘"
      and "cd = [c, d]∘"
      and "g : a ↦𝔄 c"
      and "f : b ↦𝔅 d"
proof-
  from dg_prod_is_arrD[OF assms[unfolded dg_prod_2_def]] 
  have [simp]: "vsv gf" "𝒟∘ gf = 2ℕ" "vsv ab" "𝒟∘ ab = 2ℕ" "vsv cd" "𝒟∘ cd = 2ℕ"
    and gf_app: 
      "⋀i. i ∈∘ 2ℕ ⟹ gf⦇i⦈ : ab⦇i⦈ ↦if i = 0 then 𝔄 else 𝔅 cd⦇i⦈"
    by (auto simp: two)
  have "gf = [vpfst gf, vpsnd gf]∘" by (simp add: vsv_vfsequence_two)
  moreover have "ab = [vpfst ab, vpsnd ab]∘" by (simp add: vsv_vfsequence_two)
  moreover have "cd = [vpfst cd, vpsnd cd]∘" by (simp add: vsv_vfsequence_two)
  moreover from gf_app[of 0] have "vpfst gf : vpfst ab ↦𝔄 vpfst cd" by simp
  moreover from gf_app[of ‹1ℕ›] have "vpsnd gf : vpsnd ab ↦𝔅 vpsnd cd" 
    by (simp add: nat_omega_simps)
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Domain›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dg_prod_2_Dom_vsv: "vsv ((𝔄 ×DG 𝔅)⦇Dom⦈)"
  unfolding dg_prod_2_def dg_prod_components by simp

lemma dg_prod_2_Dom_vdomain[dg_cs_simps]: 
  "𝒟∘ ((𝔄 ×DG 𝔅)⦇Dom⦈) = (𝔄 ×DG 𝔅)⦇Arr⦈"
  unfolding dg_prod_2_def dg_prod_components by simp

lemma dg_prod_2_Dom_app[dg_prod_cs_simps]:
  assumes "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  shows "(𝔄 ×DG 𝔅)⦇Dom⦈⦇g, f⦈∙ = [𝔄⦇Dom⦈⦇g⦈, 𝔅⦇Dom⦈⦇f⦈]∘"
proof-
  from assms obtain ab cd where gf: "[g, f]∘ : ab ↦𝔄 ×DG 𝔅 cd" 
    by (auto intro: is_arrI)
  then have Dom_gf: "(𝔄 ×DG 𝔅)⦇Dom⦈⦇g, f⦈∙ = ab" 
    by (simp add: dg_cs_simps)
  from gf obtain a b c d 
    where ab_def: "ab = [a, b]∘" 
      and "cd = [c, d]∘" 
      and "g : a ↦𝔄 c"
      and "f : b ↦𝔅 d"
    by (elim dg_prod_2_is_arrE[OF 𝔄 𝔅]) simp
  then have Dom_g: "𝔄⦇Dom⦈⦇g⦈ = a" and Dom_f: "𝔅⦇Dom⦈⦇f⦈ = b" 
    by (simp_all add: dg_cs_simps)
  show ?thesis unfolding Dom_gf ab_def Dom_g Dom_f ..
qed

lemma dg_prod_2_Dom_vrange: "ℛ∘ ((𝔄 ×DG 𝔅)⦇Dom⦈) ⊆∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
  show "vsv ((𝔄 ×DG 𝔅)⦇Dom⦈)" by (rule dg_prod_2_Dom_vsv)
  fix gf assume prems: "gf ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  then obtain g f where gf_def: "gf = [g, f]∘" 
    and g: "g ∈∘ 𝔄⦇Arr⦈" 
    and f: "f ∈∘ 𝔅⦇Arr⦈"
    by (elim dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
  from g f obtain a b c d where g: "g : a ↦𝔄 c" and f: "f : b ↦𝔅 d"
    by (auto intro!: is_arrI)
  from 𝔄 𝔅 g f show "(𝔄 ×DG 𝔅)⦇Dom⦈⦇gf⦈ ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
    unfolding gf_def dg_prod_2_Dom_app[OF prems[unfolded gf_def]]
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed

end


subsubsection‹Codomain›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dg_prod_2_Cod_vsv: "vsv ((𝔄 ×DG 𝔅)⦇Cod⦈)"
  unfolding dg_prod_2_def dg_prod_components by simp

lemma dg_prod_2_Cod_vdomain[dg_cs_simps]: 
  "𝒟∘ ((𝔄 ×DG 𝔅)⦇Cod⦈) = (𝔄 ×DG 𝔅)⦇Arr⦈"
  unfolding dg_prod_2_def dg_prod_components by simp

lemma dg_prod_2_Cod_app[dg_prod_cs_simps]:
  assumes "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  shows "(𝔄 ×DG 𝔅)⦇Cod⦈⦇g, f⦈∙ = [𝔄⦇Cod⦈⦇g⦈, 𝔅⦇Cod⦈⦇f⦈]∘"
proof-
  from assms obtain ab cd where gf: "[g, f]∘ : ab ↦𝔄 ×DG 𝔅 cd" 
    by (auto intro: is_arrI)
  then have Cod_gf: "(𝔄 ×DG 𝔅)⦇Cod⦈⦇g, f⦈∙ = cd"
    by (simp add: dg_cs_simps)
  from gf obtain a b c d 
    where "ab = [a, b]∘" 
      and cd_def: "cd = [c, d]∘" 
      and "g : a ↦𝔄 c"
      and "f : b ↦𝔅 d"
    by (elim dg_prod_2_is_arrE[OF 𝔄 𝔅]) simp
  then have Cod_g: "𝔄⦇Cod⦈⦇g⦈ = c" and Cod_f: "𝔅⦇Cod⦈⦇f⦈ = d"
    by (simp_all add: dg_cs_simps)
  show ?thesis unfolding Cod_gf cd_def Cod_g Cod_f ..
qed

lemma dg_prod_2_Cod_vrange: "ℛ∘ ((𝔄 ×DG 𝔅)⦇Cod⦈) ⊆∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
  show "vsv ((𝔄 ×DG 𝔅)⦇Cod⦈)" by (rule dg_prod_2_Cod_vsv)
  fix gf assume prems: "gf ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  then obtain g f where gf_def: "gf = [g, f]∘" 
    and g: "g ∈∘ 𝔄⦇Arr⦈" 
    and f: "f ∈∘ 𝔅⦇Arr⦈"
    by (elim dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
  from g f obtain a b c d where g: "g : a ↦𝔄 c" and f: "f : b ↦𝔅 d"
    by (auto intro!: is_arrI)
  from 𝔄 𝔅 g f show "(𝔄 ×DG 𝔅)⦇Cod⦈⦇gf⦈ ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
    unfolding gf_def dg_prod_2_Cod_app[OF prems[unfolded gf_def]]
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed

end


subsubsection‹Opposite product digraph›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)

lemma dg_prod_2_op_dg_dg_Obj[dg_op_simps]: 
  "(op_dg 𝔄 ×DG 𝔅)⦇Obj⦈ = (𝔄 ×DG 𝔅)⦇Obj⦈"
proof
  (
    intro vsubset_antisym vsubsetI; 
    elim dg_prod_2_ObjE[OF 𝔄.digraph_op 𝔅] dg_prod_2_ObjE[OF 𝔄 𝔅],
    (unfold dg_op_simps)?
  )
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔅⦇Obj⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔅⦇Obj⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (op_dg 𝔄 ×DG 𝔅)⦇Obj⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_op_intros dg_prod_cs_intros)  
qed

lemma dg_prod_2_dg_op_dg_Obj[dg_op_simps]: 
  "(𝔄 ×DG op_dg 𝔅)⦇Obj⦈ = (𝔄 ×DG 𝔅)⦇Obj⦈"
proof
  (
    intro vsubset_antisym vsubsetI; 
    elim dg_prod_2_ObjE[OF 𝔄 𝔅.digraph_op] dg_prod_2_ObjE[OF 𝔄 𝔅],
    (unfold dg_op_simps)?
  )
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔅⦇Obj⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Obj⦈" "b ∈∘ 𝔅⦇Obj⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG op_dg 𝔅)⦇Obj⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros) 
qed

lemma dg_prod_2_op_dg_dg_Arr[dg_op_simps]: 
  "(op_dg 𝔄 ×DG 𝔅)⦇Arr⦈ = (𝔄 ×DG 𝔅)⦇Arr⦈"
proof
  (
    intro vsubset_antisym vsubsetI; 
    elim dg_prod_2_ArrE[OF 𝔄.digraph_op 𝔅] dg_prod_2_ArrE[OF 𝔄 𝔅],
    (unfold dg_op_simps)?
  )
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Arr⦈" "b ∈∘ 𝔅⦇Arr⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Arr⦈" "b ∈∘ 𝔅⦇Arr⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (op_dg 𝔄 ×DG 𝔅)⦇Arr⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros) 
qed

lemma dg_prod_2_dg_op_dg_Arr[dg_op_simps]: 
  "(𝔄 ×DG op_dg 𝔅)⦇Arr⦈ = (𝔄 ×DG 𝔅)⦇Arr⦈"
proof
  (
    intro vsubset_antisym vsubsetI; 
    elim dg_prod_2_ArrE[OF 𝔄 𝔅.digraph_op] dg_prod_2_ArrE[OF 𝔄 𝔅],
    (unfold dg_op_simps)?
  )
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Arr⦈" "b ∈∘ 𝔅⦇Arr⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
  fix ab a b assume prems: "ab = [a, b]∘" "a ∈∘ 𝔄⦇Arr⦈" "b ∈∘ 𝔅⦇Arr⦈"
  from 𝔄 𝔅 prems(2,3) show "ab ∈∘ (𝔄 ×DG op_dg 𝔅)⦇Arr⦈"
    unfolding prems(1) dg_op_simps
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros) 
qed

end

context
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma op_dg_dg_prod_2[dg_op_simps]: "op_dg (𝔄 ×DG 𝔅) = op_dg 𝔄 ×DG op_dg 𝔅"
proof(rule vsv_eqI)

  show "vsv (op_dg (𝔄 ×DG 𝔅))" unfolding op_dg_def by auto
  show "vsv (op_dg 𝔄 ×DG op_dg 𝔅)" unfolding dg_prod_2_def dg_prod_def by auto
  have dom_lhs: "𝒟∘ (op_dg (𝔄 ×DG 𝔅)) = 4ℕ" 
    by (simp add: op_dg_def nat_omega_simps)
  show "𝒟∘ (op_dg (𝔄 ×DG 𝔅)) = 𝒟∘ (op_dg 𝔄 ×DG op_dg 𝔅)"
    unfolding dom_lhs by (simp add: dg_prod_2_def dg_prod_def nat_omega_simps)

  have Cod_Dom: "(𝔄 ×DG 𝔅)⦇Cod⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Dom⦈"
  proof(rule vsv_eqI)
    from 𝔄 𝔅 show "vsv ((𝔄 ×DG 𝔅)⦇Cod⦈)" by (rule dg_prod_2_Cod_vsv)
    from 𝔄 𝔅 show "vsv ((op_dg 𝔄 ×DG op_dg 𝔅)⦇Dom⦈)"
      by (cs_concl cs_intro: dg_prod_2_Dom_vsv dg_op_intros)+
    from 𝔄 𝔅 have dom_lhs: "𝒟∘ ((𝔄 ×DG 𝔅)⦇Cod⦈) = (𝔄 ×DG 𝔅)⦇Arr⦈"
      by (cs_concl cs_simp: dg_cs_simps)
    from 𝔄 𝔅 show "𝒟∘ ((𝔄 ×DG 𝔅)⦇Cod⦈) = 𝒟∘ ((op_dg 𝔄 ×DG op_dg 𝔅)⦇Dom⦈)"
      unfolding dom_lhs
      by (cs_concl cs_simp: dg_cs_simps dg_op_simps cs_intro: dg_op_intros)
    show "(𝔄 ×DG 𝔅)⦇Cod⦈⦇gf⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Dom⦈⦇gf⦈"
      if "gf ∈∘ 𝒟∘ ((𝔄 ×DG 𝔅)⦇Cod⦈)" for gf
      using that unfolding dom_lhs
    proof-
      assume "gf ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
      then obtain g f 
        where gf_def: "gf = [g, f]∘" 
          and g: "g ∈∘ 𝔄⦇Arr⦈" 
          and f: "f ∈∘ 𝔅⦇Arr⦈"
        by (rule dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
      from 𝔄 𝔅 g f show "(𝔄 ×DG 𝔅)⦇Cod⦈⦇gf⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Dom⦈⦇gf⦈"
        unfolding gf_def
        by 
          (
            cs_concl 
              cs_simp: dg_prod_cs_simps dg_op_simps 
              cs_intro: dg_prod_cs_intros dg_op_intros
          )
    qed
  qed

  have Dom_Cod: "(𝔄 ×DG 𝔅)⦇Dom⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Cod⦈"
  proof(rule vsv_eqI)
    from 𝔄 𝔅 show "vsv ((op_dg 𝔄 ×DG op_dg 𝔅)⦇Cod⦈)"
      by (cs_concl cs_intro: dg_prod_2_Cod_vsv dg_op_intros)+
    from 𝔄 𝔅 have dom_lhs: "𝒟∘ ((𝔄 ×DG 𝔅)⦇Dom⦈) = (𝔄 ×DG 𝔅)⦇Arr⦈"
      by (cs_concl cs_simp: dg_cs_simps)
    from 𝔄 𝔅 show "𝒟∘ ((𝔄 ×DG 𝔅)⦇Dom⦈) = 𝒟∘ ((op_dg 𝔄 ×DG op_dg 𝔅)⦇Cod⦈)"
      unfolding dom_lhs
      by (cs_concl cs_simp: dg_cs_simps dg_op_simps cs_intro: dg_op_intros)
    show "(𝔄 ×DG 𝔅)⦇Dom⦈⦇gf⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Cod⦈⦇gf⦈"
      if "gf ∈∘ 𝒟∘ ((𝔄 ×DG 𝔅)⦇Dom⦈)" for gf
      using that unfolding dom_lhs
    proof-
      assume "gf ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
      then obtain g f 
        where gf_def: "gf = [g, f]∘" 
          and g: "g ∈∘ 𝔄⦇Arr⦈" 
          and f: "f ∈∘ 𝔅⦇Arr⦈"
        by (rule dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
      from 𝔄 𝔅 g f show "(𝔄 ×DG 𝔅)⦇Dom⦈⦇gf⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Cod⦈⦇gf⦈"
        unfolding gf_def
        by 
          (
            cs_concl 
              cs_simp: dg_cs_simps dg_prod_cs_simps dg_op_simps 
              cs_intro: dg_op_intros dg_prod_cs_intros
          )
    qed
  qed (auto intro: 𝔄 𝔅 dg_prod_2_Dom_vsv)

  show "a ∈∘ 𝒟∘ (op_dg (𝔄 ×DG 𝔅)) ⟹
    op_dg (𝔄 ×DG 𝔅)⦇a⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇a⦈" 
    for a
  proof
    (
      unfold dom_lhs, 
      elim_in_numeral, 
      fold dg_field_simps, 
      unfold op_dg_components
    )
    from 𝔄 𝔅 show "(𝔄 ×DG 𝔅)⦇Obj⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Obj⦈"
      by (cs_concl cs_simp: dg_op_simps cs_intro: dg_op_intros) 
    from 𝔄 𝔅 show "(𝔄 ×DG 𝔅)⦇Arr⦈ = (op_dg 𝔄 ×DG op_dg 𝔅)⦇Arr⦈"
      by (cs_concl cs_simp: dg_op_simps cs_intro: dg_op_intros) 
  qed (auto simp: 𝔄 𝔅 Cod_Dom Dom_Cod)

qed

end



subsection‹Projections for the product of two digraphs›


subsubsection‹Definition and elementary properties›

definition dghm_proj_fst :: "V ⇒ V ⇒ V" (‹πDG.1›)
  where "πDG.1 𝔄 𝔅 = dghm_proj (2ℕ) (if2 𝔄 𝔅) 0"
definition dghm_proj_snd :: "V ⇒ V ⇒ V" (‹πDG.2›)
  where "πDG.2 𝔄 𝔅 = dghm_proj (2ℕ) (if2 𝔄 𝔅) (1ℕ)"


subsubsection‹Object map for a projection of a product of two digraphs›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dghm_proj_fst_ObjMap_app[dg_cs_simps]:
  assumes "[a, b]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
  shows "πDG.1 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈∙ = a"
proof-
  from assms have "[a, b]∘ ∈∘ (∏∘i∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈)"
    unfolding dg_prod_2_def dg_prod_components by simp
  then show "πDG.1 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈∙ = a"
    unfolding dghm_proj_fst_def dghm_proj_components dg_prod_components by simp
qed

lemma dghm_proj_snd_ObjMap_app[dg_cs_simps]:
  assumes "[a, b]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Obj⦈"
  shows "πDG.2 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈∙ = b"
proof-
  from assms have "[a, b]∘ ∈∘ (∏∘i∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈)"
    unfolding dg_prod_2_def dg_prod_components by simp
  then show "πDG.2 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈∙ = b"
    unfolding dghm_proj_snd_def dghm_proj_components dg_prod_components
    by (simp add: nat_omega_simps)
qed

end


subsubsection‹Arrow map for a projection of a product of two digraphs›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

lemma dghm_proj_fst_ArrMap_app[dg_cs_simps]:
  assumes "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  shows "πDG.1 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈∙ = g"
proof-
  from assms have "[g, f]∘ ∈∘ (∏∘i∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈)"
    unfolding dg_prod_2_def dg_prod_components by simp
  then show "πDG.1 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈∙ = g"
    unfolding dghm_proj_fst_def dghm_proj_components dg_prod_components by simp
qed

lemma dghm_proj_snd_ArrMap_app[dg_cs_simps]:
  assumes "[g, f]∘ ∈∘ (𝔄 ×DG 𝔅)⦇Arr⦈"
  shows "πDG.2 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈∙ = f"
proof-
  from assms have "[g, f]∘ ∈∘ (∏∘i∈∘2ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈)"
    unfolding dg_prod_2_def dg_prod_components by simp
  then show "πDG.2 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈∙ = f"
    unfolding dghm_proj_snd_def dghm_proj_components dg_prod_components
    by (simp add: nat_omega_simps)
qed

end


subsubsection‹Domain and codomain of a projection of a product of two digraphs›

lemma dghm_proj_fst_HomDom: "πDG.1 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×DG 𝔅"
  unfolding dghm_proj_fst_def dghm_proj_components dg_prod_2_def ..

lemma dghm_proj_fst_HomCod: "πDG.1 𝔄 𝔅⦇HomCod⦈ = 𝔄"
  unfolding dghm_proj_fst_def dghm_proj_components dg_prod_2_def by simp
  
lemma dghm_proj_snd_HomDom: "πDG.2 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×DG 𝔅"
  unfolding dghm_proj_snd_def dghm_proj_components dg_prod_2_def ..

lemma dghm_proj_snd_HomCod: "πDG.2 𝔄 𝔅⦇HomCod⦈ = 𝔅"
  unfolding dghm_proj_snd_def dghm_proj_components dg_prod_2_def by simp


subsubsection‹Projection of a product of two digraphs is a digraph homomorphism›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin

interpretation finite_pdigraph α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)

lemma dghm_proj_fst_is_dghm: 
  assumes "i ∈∘ I" 
  shows "πDG.1 𝔄 𝔅 : 𝔄 ×DG 𝔅 ↦↦DGα 𝔄"
  by 
    (
      rule pdg_dghm_proj_is_dghm[
        where i=0, simplified, folded dghm_proj_fst_def dg_prod_2_def
        ]
    )

lemma dghm_proj_fst_is_dghm'[dg_cs_intros]:
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×DG 𝔅" and "𝔇 = 𝔄"
  shows "πDG.1 𝔄 𝔅 : ℭ ↦↦DGα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule dghm_proj_fst_is_dghm)

lemma dghm_proj_snd_is_dghm:
  assumes "i ∈∘ I"
  shows "πDG.2 𝔄 𝔅 : 𝔄 ×DG 𝔅 ↦↦DGα 𝔅"
  by
    (
      rule pdg_dghm_proj_is_dghm[
        where i=‹1ℕ›, simplified, folded dghm_proj_snd_def dg_prod_2_def
        ]
    )

lemma dghm_proj_snd_is_dghm'[dg_cs_intros]:  
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×DG 𝔅" and "𝔇 = 𝔅"
  shows "πDG.2 𝔄 𝔅 : ℭ ↦↦DGα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule dghm_proj_snd_is_dghm)

end



subsection‹Product of three digraphs›
(*TODO: find a way to generalize to the product of n digraphs*)

definition dg_prod_3 :: "V ⇒ V ⇒ V ⇒ V" ("(_ ×DG3 _ ×DG3 _)" [81, 81, 81] 80)
  where "𝔄 ×DG3 𝔅 ×DG3 ℭ = (∏DGi∈∘3ℕ. if3 𝔄 𝔅 ℭ i)"


subsubsection‹Product of three digraphs is a digraph›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation 𝔅: digraph α ℭ by (rule ℭ)

lemma finite_pdigraph_dg_prod_3: 
  "finite_pdigraph α (3ℕ) (if3 𝔄 𝔅 ℭ)"
proof(intro finite_pdigraphI pdigraph_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "3ℕ ∈∘ Vset α" by blast
  show "digraph α (if3 𝔄 𝔅 ℭ i)" if "i ∈∘ 3ℕ" for i
    by (auto intro: dg_cs_intros)
qed auto

interpretation finite_pdigraph α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_pdigraph_dg_prod_3 𝔄 𝔅)

lemma digraph_dg_prod_3[dg_cs_intros]: "digraph α (𝔄 ×DG3 𝔅 ×DG3 ℭ)"
proof-
  show ?thesis unfolding dg_prod_3_def by (rule pdg_digraph_dg_prod)
qed

end


subsubsection‹Object›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

lemma dg_prod_3_ObjI:
  assumes "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈" and "c ∈∘ ℭ⦇Obj⦈"
  shows "[a, b, c]∘ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
  unfolding dg_prod_3_def dg_prod_components
proof(intro vproductI ballI)
  show "𝒟∘ [a, b, c]∘ = 3ℕ" by (simp add: nat_omega_simps)
  fix i assume "i ∈∘ 3ℕ"
  then consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› unfolding three by auto 
  then show "[a, b, c]∘⦇i⦈ ∈∘ (if3 𝔄 𝔅 ℭ i)⦇Obj⦈"
    by cases (simp_all add: nat_omega_simps assms)
qed auto

lemma dg_prod_3_ObjI'[dg_prod_cs_intros]:
  assumes "abc = [a, b, c]∘" and "a ∈∘ 𝔄⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈" and "c ∈∘ ℭ⦇Obj⦈"
  shows "abc ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
  using assms(2-4) unfolding assms(1) by (rule dg_prod_3_ObjI)

lemma dg_prod_3_ObjE:
  assumes "abc ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
  obtains a b c
    where "abc = [a, b, c]∘" 
      and "a ∈∘ 𝔄⦇Obj⦈" 
      and "b ∈∘ 𝔅⦇Obj⦈"
      and "c ∈∘ ℭ⦇Obj⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_3_def dg_prod_components]]
  have vsv_abc: "vsv abc"
    and dom_abc: "𝒟∘ abc = 3ℕ"
    and abc_app: "⋀i. i ∈∘ 3ℕ ⟹ abc⦇i⦈ ∈∘ (if3 𝔄 𝔅 ℭ i)⦇Obj⦈"
    by auto
  have dom_abc[simp]: "𝒟∘ abc = 3ℕ"
    unfolding dom_abc by (simp add: nat_omega_simps two)
  interpret vsv abc by (rule vsv_abc)
  have "abc = [vpfst abc, vpsnd abc, vpthrd abc]∘"
    by (rule vsv_vfsequence_three[symmetric]) auto
  moreover from abc_app[of 0] have "vpfst abc ∈∘ 𝔄⦇Obj⦈" by simp
  moreover from abc_app[of ‹1ℕ›] have "vpsnd abc ∈∘ 𝔅⦇Obj⦈" by simp
  moreover from abc_app[of ‹2ℕ›] have "vpthrd abc ∈∘ ℭ⦇Obj⦈" by simp
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Arrow›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

lemma dg_prod_3_ArrI:
  assumes "h ∈∘ 𝔄⦇Arr⦈" and "g ∈∘ 𝔅⦇Arr⦈" and "f ∈∘ ℭ⦇Arr⦈"
  shows "[h, g, f]∘ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  unfolding dg_prod_3_def dg_prod_components
proof(intro vproductI ballI)
  show "𝒟∘ [h, g, f]∘ = 3ℕ" by (simp add: nat_omega_simps three)
  fix i assume "i ∈∘ 3ℕ"
  then consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› unfolding three by auto 
  then show "[h, g, f]∘⦇i⦈ ∈∘ (if3 𝔄 𝔅 ℭ i)⦇Arr⦈"
    by cases (simp_all add: nat_omega_simps assms)
qed auto

lemma dg_prod_3_ArrI'[dg_prod_cs_intros]:
  assumes "hgf = [h, g, f]∘" 
    and "h ∈∘ 𝔄⦇Arr⦈" 
    and "g ∈∘ 𝔅⦇Arr⦈"
    and "f ∈∘ ℭ⦇Arr⦈"
  shows "[h, g, f]∘ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  using assms(2-4) unfolding assms(1) by (rule dg_prod_3_ArrI)

lemma dg_prod_3_ArrE:
  assumes "hgf ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  obtains h g f 
    where "hgf = [h, g, f]∘" 
      and "h ∈∘ 𝔄⦇Arr⦈" 
      and "g ∈∘ 𝔅⦇Arr⦈" 
      and "f ∈∘ ℭ⦇Arr⦈"
proof-
  from vproductD[OF assms[unfolded dg_prod_3_def dg_prod_components]]
  have vsv_hgf: "vsv hgf"
    and dom_hgf: "𝒟∘ hgf = 3ℕ"
    and hgf_app: "⋀i. i ∈∘ 3ℕ ⟹ hgf⦇i⦈ ∈∘ (if3 𝔄 𝔅 ℭ i)⦇Arr⦈"
    by auto
  have dom_hgf[simp]: "𝒟∘ hgf = 3ℕ" unfolding dom_hgf by (simp add: three)
  interpret vsv hgf by (rule vsv_hgf)
  have "hgf = [vpfst hgf, vpsnd hgf, vpthrd hgf]∘"
    by (rule vsv_vfsequence_three[symmetric]) auto
  moreover from hgf_app[of 0] have "vpfst hgf ∈∘ 𝔄⦇Arr⦈" by simp
  moreover from hgf_app[of ‹1ℕ›] have "vpsnd hgf ∈∘ 𝔅⦇Arr⦈" by simp
  moreover from hgf_app[of ‹2ℕ›] have "vpthrd hgf ∈∘ ℭ⦇Arr⦈" by simp
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Arrow with a domain and a codomain›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)
interpretation finite_pdigraph α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_pdigraph_dg_prod_3 𝔄 𝔅 ℭ)

lemma dg_prod_3_is_arrI:
  assumes "f : a ↦𝔄 b" and "f' : a' ↦𝔅 b'" and "f'' : a'' ↦ℭ b''"
  shows "[f, f', f'']∘ : [a, a', a'']∘ ↦𝔄 ×DG3 𝔅 ×DG3 ℭ [b, b', b'']∘"
  unfolding dg_prod_3_def
proof(rule dg_prod_is_arrI)
  show "[f, f', f'']∘⦇i⦈ : [a, a', a'']∘⦇i⦈ ↦if3 𝔄 𝔅 ℭ i [b, b', b'']∘⦇i⦈"
    if "i ∈∘ 3ℕ" for i
  proof-
    from that consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› unfolding three by auto 
    then show 
      "[f, f', f'']∘⦇i⦈ : [a, a', a'']∘⦇i⦈ ↦if3 𝔄 𝔅 ℭ i [b, b', b'']∘⦇i⦈"
      by cases (simp_all add: nat_omega_simps assms)
  qed
qed (auto simp: nat_omega_simps three)

lemma dg_prod_3_is_arrI'[dg_prod_cs_intros]:
  assumes "F = [f, f', f'']∘"
    and "A = [a, a', a'']∘"
    and "B = [b, b', b'']∘"
    and "f : a ↦𝔄 b"
    and "f' : a' ↦𝔅 b'"  
    and "f'' : a'' ↦ℭ b''"
  shows "F : A ↦𝔄 ×DG3 𝔅 ×DG3 ℭ B"
  using assms(4,5,6) unfolding assms(1,2,3) by (rule dg_prod_3_is_arrI)

lemma dg_prod_3_is_arrE:
  assumes "F : A ↦𝔄 ×DG3 𝔅 ×DG3 ℭ B"
  obtains f f' f'' a a' a'' b b' b'' 
    where "F = [f, f', f'']∘"
      and "A = [a, a', a'']∘"
      and "B = [b, b', b'']∘"
      and "f : a ↦𝔄 b"
      and "f' : a' ↦𝔅 b'"
      and "f'' : a'' ↦ℭ b''"
proof-
  from dg_prod_is_arrD[OF assms[unfolded dg_prod_3_def]] 
  have [simp]: "vsv F" "𝒟∘ F = 3ℕ" "vsv A" "𝒟∘ A = 3ℕ" "vsv B" "𝒟∘ B = 3ℕ"
    and F_app: "⋀i. i ∈∘ 3ℕ ⟹ F⦇i⦈ : A⦇i⦈ ↦if3 𝔄 𝔅 ℭ i B⦇i⦈"
    by (auto simp: three)
  have "F = [vpfst F, vpsnd F, vpthrd F]∘" 
    by (simp add: vsv_vfsequence_three)
  moreover have "A = [vpfst A, vpsnd A, vpthrd A]∘" 
    by (simp add: vsv_vfsequence_three)
  moreover have "B = [vpfst B, vpsnd B, vpthrd B]∘" 
    by (simp add: vsv_vfsequence_three)
  moreover from F_app[of 0] have "vpfst F : vpfst A ↦𝔄 vpfst B" by simp
  moreover from F_app[of ‹1ℕ›] have "vpsnd F : vpsnd A ↦𝔅 vpsnd B" 
    by (simp add: nat_omega_simps)
  moreover from F_app[of ‹2ℕ›] have "vpthrd F : vpthrd A ↦ℭ vpthrd B" 
    by (simp add: nat_omega_simps)
  ultimately show ?thesis using that by auto
qed

end


subsubsection‹Domain›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)

lemma dg_prod_3_Dom_vsv: "vsv ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈)"
  unfolding dg_prod_3_def dg_prod_components by simp

lemma dg_prod_3_Dom_vdomain[dg_cs_simps]: 
  "𝒟∘ ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈) = (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  unfolding dg_prod_3_def dg_prod_components by simp

lemma dg_prod_3_Dom_app[dg_prod_cs_simps]:
  assumes "[f, f', f'']∘ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  shows "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈⦇f, f', f''⦈∙ =
    [𝔄⦇Dom⦈⦇f⦈, 𝔅⦇Dom⦈⦇f'⦈, ℭ⦇Dom⦈⦇f''⦈]∘"
proof-
  from assms obtain A B where F: "[f, f', f'']∘ : A ↦𝔄 ×DG3 𝔅 ×DG3 ℭ B" 
    by (auto intro: is_arrI)
  then have Dom_F: "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈⦇f, f', f''⦈∙ = A" 
    by (simp add: dg_cs_simps)
  from F obtain a a' a'' b b' b'' 
    where A_def: "A = [a, a', a'']∘" 
      and "B = [b, b', b'']∘" 
      and "f : a ↦𝔄 b"
      and "f' : a' ↦𝔅 b'"
      and "f'' : a'' ↦ℭ b''"
    by (elim dg_prod_3_is_arrE[OF 𝔄 𝔅 ℭ]) simp
  then have Dom_f: "𝔄⦇Dom⦈⦇f⦈ = a"   
    and Dom_f': "𝔅⦇Dom⦈⦇f'⦈ = a'" 
    and Dom_f'': "ℭ⦇Dom⦈⦇f''⦈ = a''" 
    by (simp_all add: dg_cs_simps)
  show ?thesis unfolding Dom_F A_def Dom_f Dom_f' Dom_f'' ..
qed

lemma dg_prod_3_Dom_vrange: 
  "ℛ∘ ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈) ⊆∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
  show "vsv ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈)" by (rule dg_prod_3_Dom_vsv)
  fix F assume prems: "F ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  then obtain f f' f'' where F_def: "F = [f, f', f'']∘" 
    and f: "f ∈∘ 𝔄⦇Arr⦈" 
    and f': "f' ∈∘ 𝔅⦇Arr⦈"
    and f'': "f'' ∈∘ ℭ⦇Arr⦈"
    by (elim dg_prod_3_ArrE[OF 𝔄 𝔅 ℭ]) simp
  from f f' f'' obtain a a' a'' b b' b''
    where f: "f : a ↦𝔄 b" 
      and f': "f' : a' ↦𝔅 b'" 
      and f'': "f'' : a'' ↦ℭ b''" 
    by (meson is_arrI)
  from 𝔄 𝔅 f f' f'' show "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Dom⦈⦇F⦈ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
    unfolding F_def dg_prod_3_Dom_app[OF prems[unfolded F_def]]
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed

end


subsubsection‹Codomain›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin

interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)

lemma dg_prod_3_Cod_vsv: "vsv ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈)"
  unfolding dg_prod_3_def dg_prod_components by simp

lemma dg_prod_3_Cod_vdomain[dg_cs_simps]: 
  "𝒟∘ ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈) = (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  unfolding dg_prod_3_def dg_prod_components by simp

lemma dg_prod_3_Cod_app[dg_prod_cs_simps]:
  assumes "[f, f', f'']∘ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  shows 
    "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈⦇f, f', f''⦈∙ =
      [𝔄⦇Cod⦈⦇f⦈, 𝔅⦇Cod⦈⦇f'⦈, ℭ⦇Cod⦈⦇f''⦈]∘"
proof-
  from assms obtain A B where F: "[f, f', f'']∘ : A ↦𝔄 ×DG3 𝔅 ×DG3 ℭ B" 
    by (auto intro: is_arrI)
  then have Cod_F: "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈⦇f, f', f''⦈∙ = B"
    by (simp add: dg_cs_simps)
  from F obtain a a' a'' b b' b'' 
    where "A = [a, a', a'']∘" 
      and B_def: "B = [b, b', b'']∘" 
      and "f : a ↦𝔄 b"
      and "f' : a' ↦𝔅 b'"
      and "f'' : a'' ↦ℭ b''"
    by (elim dg_prod_3_is_arrE[OF 𝔄 𝔅 ℭ]) simp
  then have Cod_f: "𝔄⦇Cod⦈⦇f⦈ = b"
    and Cod_f': "𝔅⦇Cod⦈⦇f'⦈ = b'"
    and Cod_f'': "ℭ⦇Cod⦈⦇f''⦈ = b''"
    by (simp_all add: dg_cs_simps)
  show ?thesis unfolding Cod_F B_def Cod_f Cod_f' Cod_f'' ..
qed

lemma dg_prod_3_Cod_vrange: 
  "ℛ∘ ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈) ⊆∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
  show "vsv ((𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈)" by (rule dg_prod_3_Cod_vsv)
  fix F assume prems: "F ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Arr⦈"
  then obtain f f' f'' where F_def: "F = [f, f', f'']∘" 
    and f: "f ∈∘ 𝔄⦇Arr⦈" 
    and f': "f' ∈∘ 𝔅⦇Arr⦈" 
    and f'': "f'' ∈∘ ℭ⦇Arr⦈"
    by (elim dg_prod_3_ArrE[OF 𝔄 𝔅 ℭ]) simp
  from f f' f'' obtain a a' a'' b b' b'' 
    where f: "f : a ↦𝔄 b" 
      and f': "f' : a' ↦𝔅 b'"
      and f'': "f'' : a'' ↦ℭ b''"
    by (metis is_arrI)
  from 𝔄 𝔅 ℭ f f' f'' show 
    "(𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Cod⦈⦇F⦈ ∈∘ (𝔄 ×DG3 𝔅 ×DG3 ℭ)⦇Obj⦈"
    unfolding F_def dg_prod_3_Cod_app[OF prems[unfolded F_def]]
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed

end

text‹\newpage›

end

Theory CZH_DG_Subdigraph

(* Copyright 2021 (C) Mihails Milehins *)

section‹Subdigraph›
theory CZH_DG_Subdigraph
  imports 
    CZH_DG_Digraph
    CZH_DG_DGHM
begin



subsection‹Background›


text‹
In this body of work, a subdigraph is a natural generalization of the concept 
of a subcategory, as defined in Chapter I-3 in \cite{mac_lane_categories_2010}, 
to digraphs. 
It should be noted that a similar concept also exists in the conventional
graph theory, but further details are considered to be outside of the scope of 
this work.
›

named_theorems dg_sub_cs_intros
named_theorems dg_sub_bw_cs_intros
named_theorems dg_sub_fw_cs_intros
named_theorems dg_sub_bw_cs_simps



subsection‹Simple subdigraph›


subsubsection‹Definition and elementary properties›

locale subdigraph = sdg: digraph α 𝔅 + dg: digraph α ℭ for α 𝔅 ℭ +
  assumes subdg_Obj_vsubset[dg_sub_fw_cs_intros]: 
    "a ∈∘ 𝔅⦇Obj⦈ ⟹ a ∈∘ ℭ⦇Obj⦈"
    and subdg_is_arr_vsubset[dg_sub_fw_cs_intros]: 
      "f : a ↦𝔅 b ⟹ f : a ↦ℭ b"

abbreviation is_subdigraph ("(_/ ⊆DGı _)" [51, 51] 50)
  where "𝔅 ⊆DGα ℭ ≡ subdigraph α 𝔅 ℭ"

lemmas [dg_sub_fw_cs_intros] = 
  subdigraph.subdg_Obj_vsubset
  subdigraph.subdg_is_arr_vsubset


text‹Rules.›

lemma (in subdigraph) subdigraph_axioms'[dg_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆DGα' ℭ"
  unfolding assms by (rule subdigraph_axioms)

lemma (in subdigraph) subdigraph_axioms''[dg_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆DGα' ℭ'"
  unfolding assms by (rule subdigraph_axioms)

mk_ide rf subdigraph_def[unfolded subdigraph_axioms_def]
  |intro subdigraphI|
  |dest subdigraphD[dest]|
  |elim subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = subdigraphD(1,2)


text‹The opposite subdigraph.›

lemma (in subdigraph) subdg_subdigraph_op_dg_op_dg: "op_dg 𝔅 ⊆DGα op_dg ℭ"
proof(rule subdigraphI)
  show "a ∈∘ op_dg 𝔅⦇Obj⦈ ⟹ a ∈∘ op_dg ℭ⦇Obj⦈" for a
    by (auto simp: dg_op_simps subdg_Obj_vsubset)
  show "f : a ↦op_dg 𝔅 b ⟹ f : a ↦op_dg ℭ b" for f a b
    by (auto simp: dg_op_simps subdg_is_arr_vsubset)    
qed (auto simp: dg_op_simps intro: dg_op_intros)

lemmas subdg_subdigraph_op_dg_op_dg[dg_op_intros] = 
  subdigraph.subdg_subdigraph_op_dg_op_dg


text‹Further rules.›

lemma (in subdigraph) subdg_objD:
  assumes "a ∈∘ 𝔅⦇Obj⦈" 
  shows "a ∈∘ ℭ⦇Obj⦈"
  using assms by (auto intro: subdg_Obj_vsubset)

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_objD

lemma (in subdigraph) subdg_arrD[dg_sub_fw_cs_intros]:
  assumes "f ∈∘ 𝔅⦇Arr⦈" 
  shows "f ∈∘ ℭ⦇Arr⦈"
proof-
  from assms obtain a b where "f : a ↦𝔅 b" by auto
  then show "f ∈∘ ℭ⦇Arr⦈"
    by (cs_concl cs_intro: subdg_is_arr_vsubset dg_cs_intros)
qed

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_arrD

lemma (in subdigraph) subdg_dom_simp:
  assumes "f ∈∘ 𝔅⦇Arr⦈" 
  shows "𝔅⦇Dom⦈⦇f⦈ = ℭ⦇Dom⦈⦇f⦈"
proof-
  from assms obtain a b where "f : a ↦𝔅 b" by auto
  then show "𝔅⦇Dom⦈⦇f⦈ = ℭ⦇Dom⦈⦇f⦈" 
    by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed

lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_dom_simp

lemma (in subdigraph) subdg_cod_simp:
  assumes "f ∈∘ 𝔅⦇Arr⦈" 
  shows "𝔅⦇Cod⦈⦇f⦈ = ℭ⦇Cod⦈⦇f⦈"
proof-
  from assms obtain a b where "f : a ↦𝔅 b" by auto
  then show "𝔅⦇Cod⦈⦇f⦈ = ℭ⦇Cod⦈⦇f⦈" 
    by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed

lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_cod_simp

lemma (in subdigraph) subdg_is_arrD:
  assumes "f : a ↦𝔅 b" 
  shows "f : a ↦ℭ b"
  using assms subdg_is_arr_vsubset by simp

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_is_arrD


subsubsection‹The subdigraph relation is a partial order›

lemma subdg_refl: 
  assumes "digraph α 𝔄" 
  shows "𝔄 ⊆DGα 𝔄"
proof-
  interpret digraph α 𝔄 by (rule assms)
  show ?thesis by unfold_locales simp
qed

lemma subdg_trans[trans]: 
  assumes "𝔄 ⊆DGα 𝔅" and "𝔅 ⊆DGα ℭ"
  shows "𝔄 ⊆DGα ℭ"
proof-
  interpret 𝔄𝔅: subdigraph α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅ℭ: subdigraph α 𝔅 ℭ by (rule assms(2))
  show ?thesis
    by  unfold_locales
      (
        insert 𝔄𝔅.subdigraph_axioms, 
        auto simp:
          𝔅ℭ.subdg_Obj_vsubset
          𝔄𝔅.subdg_Obj_vsubset 
          subdigraph.subdg_is_arr_vsubset 
          𝔅ℭ.subdg_is_arr_vsubset
      )
qed

lemma subdg_antisym:
  assumes "𝔄 ⊆DGα 𝔅" and "𝔅 ⊆DGα 𝔄"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄𝔅: subdigraph α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅𝔄: subdigraph α 𝔅 𝔄 by (rule assms(2))
  show ?thesis
  proof(rule dg_eqI)
    from assms show Arr: "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
      by (intro vsubset_antisym vsubsetI) 
        (auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
    from assms show "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
      by (intro vsubset_antisym vsubsetI)
        (auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
    show "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
      by (rule vsv_eqI) (auto simp: 𝔄𝔅.subdg_dom_simp Arr dg_cs_simps)
    show "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈" 
      by (rule vsv_eqI) (auto simp: 𝔄𝔅.subdg_cod_simp Arr dg_cs_simps)
  qed (cs_concl cs_intro: dg_cs_intros)+
qed



subsection‹Inclusion digraph homomorphism›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

definition dghm_inc :: "V ⇒ V ⇒ V"
  where "dghm_inc 𝔅 ℭ = [vid_on (𝔅⦇Obj⦈), vid_on (𝔅⦇Arr⦈), 𝔅, ℭ]∘"


text‹Components.›

lemma dghm_inc_components:
  shows "dghm_inc 𝔅 ℭ⦇ObjMap⦈ = vid_on (𝔅⦇Obj⦈)" 
    and "dghm_inc 𝔅 ℭ⦇ArrMap⦈ = vid_on (𝔅⦇Arr⦈)" 
    and [dg_cs_simps]: "dghm_inc 𝔅 ℭ⦇HomDom⦈ = 𝔅"
    and [dg_cs_simps]: "dghm_inc 𝔅 ℭ⦇HomCod⦈ = ℭ" 
  unfolding dghm_inc_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_inc_components(1)[folded VLambda_vid_on]
  |vsv dghm_inc_ObjMap_vsv[dg_cs_intros]|
  |vdomain dghm_inc_ObjMap_vdomain[dg_cs_simps]|
  |app dghm_inc_ObjMap_app[dg_cs_simps]|


subsubsection‹Arrow map›

mk_VLambda dghm_inc_components(2)[folded VLambda_vid_on]
  |vsv dghm_inc_ArrMap_vsv[dg_cs_intros]|
  |vdomain dghm_inc_ArrMap_vdomain[dg_cs_simps]|
  |app dghm_inc_ArrMap_app[dg_cs_simps]|


subsubsection‹
Canonical inclusion digraph homomorphism associated with a subdigraph
›

sublocale subdigraph ⊆ inc: is_ft_dghm α 𝔅 ℭ ‹dghm_inc 𝔅 ℭ›
proof(intro is_ft_dghmI is_dghmI)
  show "vfsequence (dghm_inc 𝔅 ℭ)" unfolding dghm_inc_def by auto
  show "vcard (dghm_inc 𝔅 ℭ) = 4ℕ"
    unfolding dghm_inc_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dghm_inc 𝔅 ℭ⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
    unfolding dghm_inc_components by (auto dest: subdg_objD)
  show "dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇f⦈ :
    dghm_inc 𝔅 ℭ⦇ObjMap⦈⦇a⦈ ↦ℭ dghm_inc 𝔅 ℭ⦇ObjMap⦈⦇b⦈"
    if "f : a ↦𝔅 b" for a b f
    using that 
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_sub_fw_cs_intros)
  show "v11 (dghm_inc 𝔅 ℭ⦇ArrMap⦈ ↾l∘ Hom 𝔅 a b)"
    if "a ∈∘ 𝔅⦇Obj⦈" and "b ∈∘ 𝔅⦇Obj⦈" for a b
    using that unfolding dghm_inc_components by simp
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+

lemmas (in subdigraph) subdg_dghm_inc_is_ft_dghm = inc.is_ft_dghm_axioms


subsubsection‹The inclusion digraph homomorphism for the opposite digraphs›

lemma (in subdigraph) subdg_dghm_inc_op_dg_is_dghm[dg_sub_cs_intros]:
  "dghm_inc (op_dg 𝔅) (op_dg ℭ) : op_dg 𝔅 ↦↦DG.faithfulα op_dg ℭ"
  by (intro subdigraph.subdg_dghm_inc_is_ft_dghm subdg_subdigraph_op_dg_op_dg)

lemmas [dg_sub_cs_intros] = subdigraph.subdg_dghm_inc_op_dg_is_dghm

lemma (in subdigraph) subdg_op_dg_dghm_inc[dg_op_simps]: 
  "op_dghm (dghm_inc 𝔅 ℭ) = dghm_inc (op_dg 𝔅) (op_dg ℭ)"
  by (rule dghm_eqI, unfold dg_op_simps dghm_inc_components id_def)
    (
      auto 
        simp: subdg_dghm_inc_op_dg_is_dghm is_ft_dghmD 
        intro: dg_op_intros dg_cs_intros
    )

lemmas [dg_op_simps] = subdigraph.subdg_op_dg_dghm_inc



subsection‹Full subdigraph›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale fl_subdigraph = subdigraph + 
  assumes fl_subdg_is_fl_dghm_inc: "dghm_inc 𝔅 ℭ : 𝔅 ↦↦DG.fullα ℭ" 

abbreviation is_fl_subdigraph ("(_/ ⊆DG.fullı _)" [51, 51] 50)
  where "𝔅 ⊆DG.fullα ℭ ≡ fl_subdigraph α 𝔅 ℭ"

sublocale fl_subdigraph ⊆ inc: is_fl_dghm α 𝔅 ℭ ‹dghm_inc 𝔅 ℭ›
  by (rule fl_subdg_is_fl_dghm_inc)


text‹Rules.›

lemma (in fl_subdigraph) fl_subdigraph_axioms'[dg_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆DG.fullα' ℭ"
  unfolding assms by (rule fl_subdigraph_axioms)

lemma (in fl_subdigraph) fl_subdigraph_axioms''[dg_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆DG.fullα' ℭ'"
  unfolding assms by (rule fl_subdigraph_axioms)

mk_ide rf fl_subdigraph_def[unfolded fl_subdigraph_axioms_def]
  |intro fl_subdigraphI|
  |dest fl_subdigraphD[dest]|
  |elim fl_subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = fl_subdigraphD(1)


text‹Elementary properties.›

lemma (in fl_subdigraph) fl_subdg_Hom_eq:
  assumes "A ∈∘ 𝔅⦇Obj⦈" and "B ∈∘ 𝔅⦇Obj⦈"
  shows "Hom 𝔅 A B = Hom ℭ A B"
proof-
  from assms have Arr_AB: "𝔅⦇Arr⦈ ∩∘ Hom 𝔅 A B = Hom 𝔅 A B" 
    by 
      (
        intro vsubset_antisym vsubsetI, 
        unfold vintersection_iff in_Hom_iff; 
        (elim conjE)?; 
        (intro conjI)?
      )
      (auto intro: dg_cs_intros)
  from assms have A: "vid_on (𝔅⦇Obj⦈)⦇A⦈ = A" and B: "vid_on (𝔅⦇Obj⦈)⦇B⦈ = B" 
    by simp_all
  from inc.fl_dghm_surj_on_Hom[OF assms, unfolded dghm_inc_components] show
    "Hom 𝔅 A B = Hom ℭ A B"
    by (auto simp: Arr_AB A B)
qed



subsection‹Wide subdigraph›


subsubsection‹Definition and elementary properties›

text‹
See \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
›

locale wide_subdigraph = subdigraph +
  assumes wide_subdg_Obj[dg_sub_bw_cs_intros]: "a ∈∘ ℭ⦇Obj⦈ ⟹ a ∈∘ 𝔅⦇Obj⦈"

abbreviation is_wide_subdigraph ("(_/ ⊆DG.wideı _)" [51, 51] 50)
  where "𝔅 ⊆DG.wideα ℭ ≡ wide_subdigraph α 𝔅 ℭ"

lemmas [dg_sub_bw_cs_intros] = wide_subdigraph.wide_subdg_Obj


text‹Rules.›

lemma (in wide_subdigraph) wide_subdigraph_axioms'[dg_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆DG.wideα' ℭ"
  unfolding assms by (rule wide_subdigraph_axioms)

lemma (in wide_subdigraph) wide_subdigraph_axioms''[dg_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆DG.wideα' ℭ'"
  unfolding assms by (rule wide_subdigraph_axioms)

mk_ide rf wide_subdigraph_def[unfolded wide_subdigraph_axioms_def]
  |intro wide_subdigraphI|
  |dest wide_subdigraphD[dest]|
  |elim wide_subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = wide_subdigraphD(1)


text‹Elementary properties.›

lemma (in wide_subdigraph) wide_subdg_obj_eq[dg_sub_bw_cs_simps]: 
  "𝔅⦇Obj⦈ = ℭ⦇Obj⦈"
  using subdg_Obj_vsubset wide_subdg_Obj by auto

lemmas [dg_sub_bw_cs_simps] = wide_subdigraph.wide_subdg_obj_eq


subsubsection‹The wide subdigraph relation is a partial order›

lemma wide_subdg_refl: 
  assumes "digraph α 𝔄" 
  shows "𝔄 ⊆DG.wideα 𝔄"
proof-
  interpret digraph α 𝔄 by (rule assms)
  show ?thesis by unfold_locales simp
qed

lemma wide_subdg_trans[trans]: 
  assumes "𝔄 ⊆DG.wideα 𝔅" and "𝔅 ⊆DG.wideα ℭ"
  shows "𝔄 ⊆DG.wideα ℭ"
proof-
  interpret 𝔄𝔅: wide_subdigraph α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅ℭ: wide_subdigraph α 𝔅 ℭ by (rule assms(2))
  interpret 𝔄ℭ: subdigraph α 𝔄 ℭ 
    by (rule subdg_trans) (cs_concl cs_intro: dg_cs_intros)+
  show ?thesis
    by (cs_concl cs_intro: dg_sub_bw_cs_intros dg_cs_intros wide_subdigraphI)
qed

lemma wide_subdg_antisym:
  assumes "𝔄 ⊆DG.wideα 𝔅" and "𝔅 ⊆DG.wideα 𝔄"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄𝔅: wide_subdigraph α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅𝔄: wide_subdigraph α 𝔅 𝔄 by (rule assms(2))
  show ?thesis 
    by (rule subdg_antisym[OF 𝔄𝔅.subdigraph_axioms 𝔅𝔄.subdigraph_axioms])
qed

text‹\newpage›

end

Theory CZH_DG_Simple

(* Copyright 2021 (C) Mihails Milehins *)

section‹Simple digraphs›
theory CZH_DG_Simple
  imports CZH_DG_DGHM
begin



subsection‹Background›


text‹
The section presents a variety of simple digraphs, such as the empty digraph ‹0›
and a digraph with one object and one arrow ‹1›. All of the entities 
presented in this section are generalizations of certain simple categories,
whose definitions can be found in \cite{mac_lane_categories_2010}.
›



subsection‹Empty digraph ‹0››


subsubsection‹Definition and elementary properties›


text‹See Chapter I-2 in \cite{mac_lane_categories_2010}.›

definition dg_0 :: V
  where "dg_0 = [0, 0, 0, 0]∘"


text‹Components.›

lemma dg_0_components:
  shows "dg_0⦇Obj⦈ = 0"
    and "dg_0⦇Arr⦈ = 0"
    and "dg_0⦇Dom⦈ = 0"
    and "dg_0⦇Cod⦈ = 0"
  unfolding dg_0_def dg_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹‹0› is a digraph›

lemma (in 𝒵) digraph_dg_0: "digraph α dg_0"
proof(intro digraphI)
  show "vfsequence dg_0" unfolding dg_0_def by (simp add: nat_omega_simps)
  show "vcard dg_0 = 4ℕ" unfolding dg_0_def by (simp add: nat_omega_simps)
qed (auto simp: dg_0_components)


subsubsection‹Arrow with a domain and a codomain›

lemma dg_0_is_arr_iff[simp]: "𝔉 : 𝔄 ↦dg_0 𝔅 ⟷ False" 
  by (rule iffI; (elim is_arrE)?) (auto simp: dg_0_components)


subsubsection‹A digraph without objects is empty›

lemma (in digraph) dg_dg_0_if_Obj_0:
  assumes "ℭ⦇Obj⦈ = 0"
  shows "ℭ = dg_0"
  by (rule dg_eqI[of α])
    (
      auto simp:
        dg_cs_intros
        assms
        digraph_dg_0 
        dg_0_components 
        dg_Arr_vempty_if_Obj_vempty 
        dg_Cod_vempty_if_Arr_vempty 
        dg_Dom_vempty_if_Arr_vempty
    )



subsection‹Empty digraph homomorphism›


subsubsection‹Definition and elementary properties›

definition dghm_0 :: "V ⇒ V"
  where "dghm_0 𝔄 = [0, 0, dg_0, 𝔄]∘"


text‹Components.›

lemma dghm_0_components:
  shows "dghm_0 𝔄⦇ObjMap⦈ = 0"
    and "dghm_0 𝔄⦇ArrMap⦈ = 0"
    and "dghm_0 𝔄⦇HomDom⦈ = dg_0"
    and "dghm_0 𝔄⦇HomCod⦈ = 𝔄"
  unfolding dghm_0_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Empty digraph homomorphism is a faithful digraph homomorphism›

lemma (in 𝒵) dghm_0_is_dghm: 
  assumes "digraph α 𝔄"
  shows "dghm_0 𝔄 : dg_0 ↦↦DG.faithfulα 𝔄"
proof(rule is_ft_dghmI)
  show "dghm_0 𝔄 : dg_0 ↦↦DGα 𝔄"
  proof(rule is_dghmI)
    show "vfsequence (dghm_0 𝔄)" unfolding dghm_0_def by simp
    show "vcard (dghm_0 𝔄) = 4ℕ"
      unfolding dghm_0_def by (simp add: nat_omega_simps)
  qed (auto simp: assms digraph_dg_0 dghm_0_components dg_0_components)
qed (auto simp: dg_0_components dghm_0_components)



subsection‹‹10›: digraph with one object and no arrows›


subsubsection‹Definition and elementary properties›

definition dg_10 :: "V ⇒ V"
  where "dg_10 𝔞 = [set {𝔞}, 0, 0, 0]∘"


text‹Components.›

lemma dg_10_components:
  shows "dg_10 𝔞⦇Obj⦈ = set {𝔞}"
    and "dg_10 𝔞⦇Arr⦈ = 0"
    and "dg_10 𝔞⦇Dom⦈ = 0"
    and "dg_10 𝔞⦇Cod⦈ = 0"
  unfolding dg_10_def dg_field_simps by (auto simp: nat_omega_simps)


subsubsection‹‹10› is a digraph›

lemma (in 𝒵) digraph_dg_10: 
  assumes "𝔞 ∈∘ Vset α" 
  shows "digraph α (dg_10 𝔞)"
proof(intro digraphI)
  show "vfsequence (dg_10 𝔞)" unfolding dg_10_def by (simp add: nat_omega_simps)
  show "vcard (dg_10 𝔞) = 4ℕ" unfolding dg_10_def by (simp add: nat_omega_simps)
  show "(⋃∘a'∈∘A. ⋃∘b'∈∘B. Hom (dg_10 𝔞) a' b') ∈∘ Vset α" for A B
  proof-
    have "(⋃∘a'∈∘A. ⋃∘b'∈∘B. Hom (dg_10 𝔞) a' b') ⊆∘ dg_10 𝔞⦇Arr⦈" by auto
    moreover have "dg_10 𝔞⦇Arr⦈ ⊆∘ 0" unfolding dg_10_components by auto
    ultimately show ?thesis using vempty_is_zet vsubset_in_VsetI by presburger
  qed
qed (auto simp: assms dg_10_components vsubset_vsingleton_leftI)


subsubsection‹Arrow with a domain and a codomain›

lemma dg_10_is_arr_iff: "𝔉 : 𝔄 ↦dg_10 𝔞 𝔅 ⟷ False"
  unfolding is_arr_def dg_10_components by simp



subsection‹‹1›: digraph with one object and one arrow›


subsubsection‹Definition and elementary properties›

definition dg_1 :: "V ⇒ V ⇒ V"
  where "dg_1 𝔞 𝔣 = [set {𝔞}, set {𝔣}, set {⟨𝔣, 𝔞⟩}, set {⟨𝔣, 𝔞⟩}]∘"


text‹Components.›

lemma dg_1_components:
  shows "dg_1 𝔞 𝔣⦇Obj⦈ = set {𝔞}"
    and "dg_1 𝔞 𝔣⦇Arr⦈ = set {𝔣}"
    and "dg_1 𝔞 𝔣⦇Dom⦈ = set {⟨𝔣, 𝔞⟩}"
    and "dg_1 𝔞 𝔣⦇Cod⦈ = set {⟨𝔣, 𝔞⟩}"
  unfolding dg_1_def dg_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹‹1› is a digraph›

lemma (in 𝒵) digraph_dg_1: 
  assumes "𝔞 ∈∘ Vset α" and "𝔣 ∈∘ Vset α" 
  shows "digraph α (dg_1 𝔞 𝔣)"
proof(intro digraphI)
  show "vfsequence (dg_1 𝔞 𝔣)" unfolding dg_1_def by (simp add: nat_omega_simps)
  show "vcard (dg_1 𝔞 𝔣) = 4ℕ" unfolding dg_1_def by (simp add: nat_omega_simps)
  show "(⋃∘a'∈∘A. ⋃∘b'∈∘B. Hom (dg_1 𝔞 𝔣) a' b') ∈∘ Vset α" for A B
  proof-
    have "(⋃∘a'∈∘A. ⋃∘b'∈∘B. Hom (dg_1 𝔞 𝔣) a' b') ⊆∘ dg_1 𝔞 𝔣⦇Arr⦈" by auto
    moreover have "dg_1 𝔞 𝔣⦇Arr⦈ ⊆∘ set {𝔣}" unfolding dg_1_components by auto
    moreover from assms(2) have "set {𝔣} ∈∘ Vset α" 
      by (simp add: Limit_vsingleton_in_VsetI)
    ultimately show ?thesis 
      unfolding dg_1_components by (auto simp: vsubset_in_VsetI)
  qed
qed (auto simp: assms dg_1_components vsubset_vsingleton_leftI)


subsubsection‹Arrow with a domain and a codomain›

lemma dg_1_is_arrI:
  assumes "a = 𝔞" and "b = 𝔞" and "f = 𝔣" 
  shows "f : a ↦dg_1 𝔞 𝔣 b"
  using assms by (intro is_arrI) (auto simp: dg_1_components)

lemma dg_1_is_arrD:
  assumes "f : a ↦dg_1 𝔞 𝔣 b"
  shows "a = 𝔞" and "b = 𝔞" and "f = 𝔣" 
  using assms by (all‹elim is_arrE›) (auto simp: dg_1_components)

lemma dg_1_is_arrE:
  assumes "f : a ↦dg_1 𝔞 𝔣 b"
  obtains "a = 𝔞" and "b = 𝔞" and "f = 𝔣" 
  using assms by (elim is_arrE) (force simp: dg_1_components)

lemma dg_1_is_arr_iff: "f : a ↦dg_1 𝔞 𝔣 b ⟷ (a = 𝔞 ∧ b = 𝔞 ∧ f = 𝔣)" 
  by (rule iffI; (elim is_arrE)?) 
    (auto simp: dg_1_components intro: dg_1_is_arrI)

text‹\newpage›

end

Theory CZH_DG_GRPH

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹GRPH› as a digraph›
theory CZH_DG_GRPH
  imports 
    CZH_DG_DGHM
    CZH_DG_Small_Digraph
begin



subsection‹Background›


text‹
Conventionally, ‹GRPH› defined as a category of digraphs and digraph 
homomorphisms (e.g., see Chapter II-7 in \cite{mac_lane_categories_2010}).
However, there is little that can prevent one from exposing ‹GRPH›
as a digraph and provide additional structure gradually in 
subsequent installments of this work. Thus, in this section, ‹α›-‹GRPH› is 
defined as a digraph of digraphs and digraph homomorphisms in ‹Vα›.
›

named_theorems GRPH_cs_simps
named_theorems GRPH_cs_intros



subsection‹Definition and elementary properties›

definition dg_GRPH :: "V ⇒ V"
  where "dg_GRPH α =
    [
      set {ℭ. digraph α ℭ},
      all_dghms α,
      (λ𝔉∈∘all_dghms α. 𝔉⦇HomDom⦈),
      (λ𝔉∈∘all_dghms α. 𝔉⦇HomCod⦈)
    ]∘"


text‹Components.›

lemma dg_GRPH_components:
  shows "dg_GRPH α⦇Obj⦈ = set {ℭ. digraph α ℭ}"
    and "dg_GRPH α⦇Arr⦈ = all_dghms α"
    and "dg_GRPH α⦇Dom⦈ = (λ𝔉∈∘all_dghms α. 𝔉⦇HomDom⦈)"
    and "dg_GRPH α⦇Cod⦈ = (λ𝔉∈∘all_dghms α. 𝔉⦇HomCod⦈)"
  unfolding dg_GRPH_def dg_field_simps by (simp_all add: nat_omega_simps)



subsection‹Object›

lemma dg_GRPH_ObjI:
  assumes "digraph α 𝔄"
  shows "𝔄 ∈∘ dg_GRPH α⦇Obj⦈"
  using assms unfolding dg_GRPH_components by auto

lemma dg_GRPH_ObjD:
  assumes "𝔄 ∈∘ dg_GRPH α⦇Obj⦈"
  shows "digraph α 𝔄"
  using assms unfolding dg_GRPH_components by auto

lemma dg_GRPH_ObjE:
  assumes "𝔄 ∈∘ dg_GRPH α⦇Obj⦈"
  obtains "digraph α 𝔄"
  using assms unfolding dg_GRPH_components by auto

lemma dg_GRPH_Obj_iff[GRPH_cs_simps]: 
  "𝔄 ∈∘ dg_GRPH α⦇Obj⦈ ⟷ digraph α 𝔄"
  unfolding dg_GRPH_components by auto



subsection‹Domain›

mk_VLambda dg_GRPH_components(3)
  |vsv dg_GRPH_Dom_vsv[GRPH_cs_intros]|
  |vdomain dg_GRPH_Dom_vdomain[GRPH_cs_simps]|
  |app dg_GRPH_Dom_app[GRPH_cs_simps]|

lemma dg_GRPH_Dom_vrange: "ℛ∘ (dg_GRPH α⦇Dom⦈) ⊆∘ dg_GRPH α⦇Obj⦈"
  unfolding dg_GRPH_components by (rule vrange_VLambda_vsubset) auto



subsection‹Codomain›

mk_VLambda dg_GRPH_components(4)
  |vsv dg_GRPH_Cod_vsv[GRPH_cs_intros]|
  |vdomain dg_GRPH_Cod_vdomain[GRPH_cs_simps]|
  |app dg_GRPH_Cod_app[GRPH_cs_simps]|

lemma dg_GRPH_Cod_vrange: "ℛ∘ (dg_GRPH α⦇Cod⦈) ⊆∘ dg_GRPH α⦇Obj⦈"
  unfolding dg_GRPH_components by (rule vrange_VLambda_vsubset) auto



subsection‹‹GRPH› is a digraph›

lemma (in 𝒵) tiny_digraph_dg_GRPH: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_digraph β (dg_GRPH α)"
proof(intro tiny_digraphI)
  show "vfsequence (dg_GRPH α)" unfolding dg_GRPH_def by simp
  show "vcard (dg_GRPH α) = 4ℕ"
    unfolding dg_GRPH_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dg_GRPH α⦇Dom⦈) ⊆∘ dg_GRPH α⦇Obj⦈" by (simp add: dg_GRPH_Dom_vrange)
  show "ℛ∘ (dg_GRPH α⦇Cod⦈) ⊆∘ dg_GRPH α⦇Obj⦈" by (simp add: dg_GRPH_Cod_vrange)
  show "dg_GRPH α⦇Obj⦈ ∈∘ Vset β"
    unfolding dg_GRPH_components by (rule digraphs_in_Vset[OF assms])
  show "dg_GRPH α⦇Arr⦈ ∈∘ Vset β"
    unfolding dg_GRPH_components by (rule all_dghms_in_Vset[OF assms])
qed (auto simp: assms dg_GRPH_components)



subsection‹Arrow with a domain and a codomain›

lemma dg_GRPH_is_arrI:
  assumes "𝔉 : 𝔄 ↦↦DGα 𝔅" 
  shows "𝔉 : 𝔄 ↦dg_GRPH α 𝔅"
proof(intro is_arrI; unfold dg_GRPH_components)
  from assms show "𝔉 ∈∘ all_dghms α" by auto
  with assms show 
    "(λ𝔉∈∘all_dghms α. 𝔉⦇HomDom⦈)⦇𝔉⦈ = 𝔄" 
    "(λ𝔉∈∘all_dghms α. 𝔉⦇HomCod⦈)⦇𝔉⦈ = 𝔅"
    by (auto simp: GRPH_cs_simps)
qed

lemma dg_GRPH_is_arrD:
  assumes "𝔉 : 𝔄 ↦dg_GRPH α 𝔅"
  shows "𝔉 : 𝔄 ↦↦DGα 𝔅" 
  using assms by (elim is_arrE) (auto simp: dg_GRPH_components)

lemma dg_GRPH_is_arrE:
  assumes "𝔉 : 𝔄 ↦dg_GRPH α 𝔅"
  obtains "𝔉 : 𝔄 ↦↦DGα 𝔅"
  using assms by (simp add: dg_GRPH_is_arrD)

lemma dg_GRPH_is_arr_iff[GRPH_cs_simps]: 
  "𝔉 : 𝔄 ↦dg_GRPH α 𝔅 ⟷ 𝔉 : 𝔄 ↦↦DGα 𝔅" 
  by (auto intro: dg_GRPH_is_arrI dest: dg_GRPH_is_arrD)

text‹\newpage›

end

Theory CZH_DG_Rel

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Rel› as a digraph›
theory CZH_DG_Rel
  imports CZH_DG_Small_DGHM
begin



subsection‹Background›


text‹
‹Rel› is usually defined as a category of sets and binary relations
(e.g., see Chapter I-7 in \cite{mac_lane_categories_2010}). However, there
is little that can prevent one from exposing ‹Rel› as a digraph and
provide additional structure gradually in subsequent installments of this 
work. Thus, in this section, ‹α›-‹Rel› is defined as a digraph of sets 
and binary relations in ‹Vα›.
›

named_theorems dg_Rel_shared_cs_simps
named_theorems dg_Rel_shared_cs_intros

named_theorems dg_Rel_cs_simps
named_theorems dg_Rel_cs_intros



subsection‹Canonical arrow for typ‹V››

named_theorems arr_field_simps

definition ArrVal :: V where [arr_field_simps]: "ArrVal = 0"
definition ArrDom :: V where [arr_field_simps]: "ArrDom = 1ℕ"
definition ArrCod :: V where [arr_field_simps]: "ArrCod = 2ℕ"

lemma ArrVal_eq_helper:
  assumes "f = g"
  shows "f⦇ArrVal⦈⦇a⦈ = g⦇ArrVal⦈⦇a⦈"
  using assms by simp



subsection‹Arrow for ‹Rel››


subsubsection‹Definition and elementary properties›

locale arr_Rel = 𝒵 α + vfsequence T + ArrVal: vbrelation ‹T⦇ArrVal⦈› for α T +
  assumes arr_Rel_length[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: 
    "vcard T = 3ℕ" 
    and arr_Rel_ArrVal_vdomain: "𝒟∘ (T⦇ArrVal⦈) ⊆∘ T⦇ArrDom⦈"
    and arr_Rel_ArrVal_vrange: "ℛ∘ (T⦇ArrVal⦈) ⊆∘ T⦇ArrCod⦈"
    and arr_Rel_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈∘ Vset α"
    and arr_Rel_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈∘ Vset α"

lemmas [dg_Rel_cs_simps] = arr_Rel.arr_Rel_length


text‹Components.›

lemma arr_Rel_components[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  shows "[f, A, B]∘⦇ArrVal⦈ = f"
    and "[f, A, B]∘⦇ArrDom⦈ = A"
    and "[f, A, B]∘⦇ArrCod⦈ = B"
  unfolding arr_field_simps by (simp_all add: nat_omega_simps)


text‹Rules.›

mk_ide rf arr_Rel_def[unfolded arr_Rel_axioms_def]
  |intro arr_RelI|
  |dest arr_RelD[dest]|
  |elim arr_RelE[elim!]|

lemma (in 𝒵) arr_Rel_vfsequenceI: 
  assumes "vbrelation r" 
    and "𝒟∘ r ⊆∘ a"
    and "ℛ∘ r ⊆∘ b"
    and "a ∈∘ Vset α"
    and "b ∈∘ Vset α"
  shows "arr_Rel α [r, a, b]∘"
  by (intro arr_RelI) 
    (insert assms, auto simp: nat_omega_simps arr_Rel_components)


text‹Elementary properties.›

lemma arr_Rel_eqI:
  assumes "arr_Rel α S" 
    and "arr_Rel α T"
    and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
    and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
    and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
  shows "S = T"
proof-
  interpret S: arr_Rel α S by (rule assms(1))
  interpret T: arr_Rel α T by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    show "𝒟∘ S = 𝒟∘ T" 
      by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Rel_cs_simps) 
    have dom_lhs: "𝒟∘ S = 3ℕ" 
      by (simp add: S.vfsequence_vdomain dg_Rel_cs_simps)
    show "a ∈∘ 𝒟∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a 
      by (unfold dom_lhs, elim_in_numeral, insert assms)
        (auto simp: arr_field_simps)
  qed auto
qed

lemma (in arr_Rel) arr_Rel_def: "T = [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ T = 3ℕ" by (simp add: vfsequence_vdomain dg_Rel_cs_simps)
  have dom_rhs: "𝒟∘ [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘ = 3ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ T = 𝒟∘ [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ T ⟹ T⦇a⦈ = [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘⦇a⦈" for a
    unfolding dom_lhs
    by elim_in_numeral (simp_all add: arr_field_simps nat_omega_simps)
qed (auto simp: vsv_axioms)


text‹Size.›

lemma (in arr_Rel) arr_Rel_ArrVal_in_Vset: "T⦇ArrVal⦈ ∈∘ Vset α"
proof-
  from arr_Rel_ArrVal_vdomain arr_Rel_ArrDom_in_Vset have 
    "𝒟∘ (T⦇ArrVal⦈) ∈∘ Vset α"
    by auto
  moreover from arr_Rel_ArrVal_vrange arr_Rel_ArrCod_in_Vset have 
    "ℛ∘ (T⦇ArrVal⦈) ∈∘ Vset α"
    by auto
  ultimately show "T⦇ArrVal⦈ ∈∘ Vset α" 
    by (simp add: ArrVal.vbrelation_Limit_in_VsetI)
qed

lemma (in arr_Rel) arr_Rel_in_Vset: "T ∈∘ Vset α"
proof-
  note [dg_Rel_cs_intros] = 
    arr_Rel_ArrVal_in_Vset arr_Rel_ArrDom_in_Vset arr_Rel_ArrCod_in_Vset
  show ?thesis
    by (subst arr_Rel_def)
      (cs_concl cs_intro: dg_Rel_cs_intros V_cs_intros) 
qed

lemma small_arr_Rel[simp]: "small {T. arr_Rel α T}"
  by (rule down[of _ ‹Vset α›]) (auto intro!: arr_Rel.arr_Rel_in_Vset)


text‹Other elementary properties.›

lemma set_Collect_arr_Rel[simp]: 
  "x ∈∘ set (Collect (arr_Rel α)) ⟷ arr_Rel α x" 
  by auto

lemma (in arr_Rel) arr_Rel_ArrVal_vsubset_ArrDom_ArrCod:
  "T⦇ArrVal⦈ ⊆∘ T⦇ArrDom⦈ ×∘ T⦇ArrCod⦈"
proof
  fix ab assume "ab ∈∘ T⦇ArrVal⦈"
  then obtain a b where "ab = ⟨a, b⟩" 
    and "a ∈∘ 𝒟∘ (T⦇ArrVal⦈)" 
    and "b ∈∘ ℛ∘ (T⦇ArrVal⦈)" 
    by (blast elim: ArrVal.vbrelation_vinE)
  with arr_Rel_ArrVal_vdomain arr_Rel_ArrVal_vrange show 
    "ab ∈∘ T⦇ArrDom⦈ ×∘ T⦇ArrCod⦈"
    by auto
qed


subsubsection‹Composition›


text‹See Chapter I-7 in \cite{mac_lane_categories_2010}.›

definition comp_Rel :: "V ⇒ V ⇒ V" (infixl ‹∘Rel› 55)
  where "comp_Rel S T = [S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈, T⦇ArrDom⦈, S⦇ArrCod⦈]∘"


text‹Components.›

lemma comp_Rel_components:
  shows "(S ∘Rel T)⦇ArrVal⦈ = S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: 
      "(S ∘Rel T)⦇ArrDom⦈ = T⦇ArrDom⦈"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
      "(S ∘Rel T)⦇ArrCod⦈ = S⦇ArrCod⦈"
  unfolding comp_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)


text‹Elementary properties.›

lemma comp_Rel_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]: 
  "vsv (S ∘Rel T)"
  unfolding comp_Rel_def by auto

lemma arr_Rel_comp_Rel[dg_Rel_cs_intros]:
  assumes "arr_Rel α S" and "arr_Rel α T"
  shows "arr_Rel α (S ∘Rel T)"
proof-
  interpret S: arr_Rel α S by (rule assms(1))
  interpret T: arr_Rel α T by (rule assms(2))
  show ?thesis
  proof(intro arr_RelI)
    show "vfsequence (S ∘Rel T)" unfolding comp_Rel_def by simp
    show "vcard (S ∘Rel T) = 3ℕ"
      unfolding comp_Rel_def by (simp add: nat_omega_simps)
    from T.arr_Rel_ArrVal_vdomain show 
      "𝒟∘ ((S ∘Rel T)⦇ArrVal⦈) ⊆∘ (S ∘Rel T)⦇ArrDom⦈"
      unfolding comp_Rel_components by auto
    show "ℛ∘ ((S ∘Rel T)⦇ArrVal⦈) ⊆∘ (S ∘Rel T)⦇ArrCod⦈"
      unfolding comp_Rel_components 
    proof(intro vsubsetI)
      fix z assume "z ∈∘ ℛ∘ (S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈)"
      then obtain x y where "⟨y, z⟩ ∈∘ S⦇ArrVal⦈" and "⟨x, y⟩ ∈∘ T⦇ArrVal⦈"
        by (meson vcomp_obtain_middle vrange_iff_vdomain)
      with S.arr_Rel_ArrVal_vrange show "z ∈∘ S⦇ArrCod⦈" by auto
    qed
  qed 
    (
      auto simp: 
        comp_Rel_components T.arr_Rel_ArrDom_in_Vset S.arr_Rel_ArrCod_in_Vset
    ) 
qed

lemma arr_Rel_comp_Rel_assoc[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "(H ∘Rel G) ∘Rel F = H ∘Rel (G ∘Rel F)" 
  by (simp add: comp_Rel_def vcomp_assoc arr_field_simps nat_omega_simps)


subsubsection‹Inclusion arrow›


text‹
The definition of the inclusion arrow is based on the concept of the 
inclusion map, e.g., see \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Inclusion_map}
}›

definition "incl_Rel A B = [vid_on A, A, B]∘"


text‹Components.›

lemma incl_Rel_components:
  shows "incl_Rel A B⦇ArrVal⦈ = vid_on A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B⦇ArrDom⦈ = A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B⦇ArrCod⦈ = B"
  unfolding incl_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)


text‹Arrow value.›

lemma incl_Rel_ArrVal_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]: 
  "vsv (incl_Rel A B⦇ArrVal⦈)"
  unfolding incl_Rel_components by simp

lemma incl_Rel_ArrVal_vdomain[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  "𝒟∘ (incl_Rel A B⦇ArrVal⦈) = A"
  unfolding incl_Rel_components by simp

lemma incl_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  assumes "a ∈∘ A"
  shows "incl_Rel A B⦇ArrVal⦈⦇a⦈ = a"
  using assms unfolding incl_Rel_components by simp


text‹Elementary properties.›

lemma incl_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]: 
  "vfsequence (incl_Rel A B)" 
  unfolding incl_Rel_def by simp

lemma incl_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: 
  "vcard (incl_Rel A B) = 3ℕ" 
  unfolding incl_Rel_def incl_Rel_def by (simp add: nat_omega_simps)

lemma (in 𝒵) arr_Rel_incl_RelI:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "arr_Rel α (incl_Rel A B)"
proof(intro arr_RelI)
  show "vfsequence (incl_Rel A B)" unfolding incl_Rel_def by simp
  show "vcard (incl_Rel A B) = 3ℕ" 
    unfolding incl_Rel_def by (simp add: nat_omega_simps)
qed (auto simp: incl_Rel_components assms)


subsubsection‹Identity›


text‹See Chapter I-7 in \cite{mac_lane_categories_2010}.›

definition id_Rel :: "V ⇒ V"
  where "id_Rel A = incl_Rel A A"


text‹Components.›

lemma id_Rel_components:
  shows "id_Rel A⦇ArrVal⦈ = vid_on A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A⦇ArrDom⦈ = A"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A⦇ArrCod⦈ = A"
  unfolding id_Rel_def incl_Rel_components by simp_all


text‹Elementary properties.›

lemma id_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]: 
  "vfsequence (id_Rel A)" 
  unfolding id_Rel_def by (simp add: dg_Rel_cs_intros)

lemma id_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: 
  "vcard (id_Rel A) = 3ℕ" 
  unfolding id_Rel_def by (simp add: dg_Rel_cs_simps)

lemma (in 𝒵) arr_Rel_id_RelI:
  assumes "A ∈∘ Vset α"
  shows "arr_Rel α (id_Rel A)"
  by (intro arr_RelI)
    (auto simp: id_Rel_components(1) assms dg_Rel_cs_intros dg_Rel_cs_simps)

lemma id_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
  assumes "a ∈∘ A"
  shows "id_Rel A⦇ArrVal⦈⦇a⦈ = a"
  using assms unfolding id_Rel_components by simp

lemma arr_Rel_comp_Rel_id_Rel_left[dg_Rel_cs_simps]:
  assumes "arr_Rel α F" and "F⦇ArrCod⦈ = A"
  shows "id_Rel A ∘Rel F = F"
proof(rule arr_Rel_eqI [of α])
  interpret F: arr_Rel α F by (rule assms(1))
  from assms(2) have "A ∈∘ Vset α" by (auto intro: F.arr_Rel_ArrCod_in_Vset)
  with assms(1) show "arr_Rel α (id_Rel A ∘Rel F)" 
    by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
  from assms(2) F.arr_Rel_ArrVal_vrange show  
    "(id_Rel A ∘Rel F)⦇ArrVal⦈ = F⦇ArrVal⦈"
    unfolding comp_Rel_components id_Rel_components by auto
qed 
  (
    use assms(2) in 
      ‹auto simp: assms(1) comp_Rel_components id_Rel_components›
  )

lemma arr_Rel_comp_Rel_id_Rel_right[dg_Rel_cs_simps]:
  assumes "arr_Rel α F" and "F⦇ArrDom⦈ = A"
  shows "F ∘Rel id_Rel A = F"
proof(rule arr_Rel_eqI[of α])
  interpret F: arr_Rel α F by (rule assms(1))
  from assms(2) have "A ∈∘ Vset α" by (auto intro: F.arr_Rel_ArrDom_in_Vset)
  with assms(1) show "arr_Rel α (F ∘Rel id_Rel A)"
    by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
  show "arr_Rel α F" by (simp add: assms(1))
  from assms(2) F.arr_Rel_ArrVal_vdomain show  
    "(F ∘Rel id_Rel A)⦇ArrVal⦈ = F⦇ArrVal⦈"
    unfolding comp_Rel_components id_Rel_components by auto
qed (use assms(2) in ‹auto simp: comp_Rel_components id_Rel_components›)


subsubsection‹Converse›


text‹
As mentioned in Chapter I-7 in \cite{mac_lane_categories_2010}, the 
category ‹Rel› is usually equipped with an additional structure that is
the operation of taking a converse of a relation.
The operation is meant to be used almost exclusively as part of 
the dagger functor for ‹Rel›.
›

definition converse_Rel :: "V ⇒ V" ("(_¯Rel)" [1000] 999)
  where "converse_Rel T = [(T⦇ArrVal⦈)¯∘, T⦇ArrCod⦈, T⦇ArrDom⦈]∘"

lemma converse_Rel_components:
  shows "T¯Rel⦇ArrVal⦈ = (T⦇ArrVal⦈)¯∘"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T¯Rel⦇ArrDom⦈ = T⦇ArrCod⦈"
    and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T¯Rel⦇ArrCod⦈ = T⦇ArrDom⦈"
  unfolding converse_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)


text‹Elementary properties.›

lemma (in arr_Rel) arr_Rel_converse_Rel: "arr_Rel α (T¯Rel)"
proof(rule arr_RelI, unfold converse_Rel_components)
  show "vfsequence (T¯Rel)" unfolding converse_Rel_def by simp
  show "vcard (T¯Rel) = 3ℕ"
    unfolding converse_Rel_def by (simp add: nat_omega_simps)
qed 
  (
    auto simp: 
      converse_Rel_components(1)   
      arr_Rel_ArrDom_in_Vset 
      arr_Rel_ArrCod_in_Vset
      arr_Rel_ArrVal_vdomain
      arr_Rel_ArrVal_vrange
  )

lemmas [dg_Rel_cs_intros] = 
  arr_Rel.arr_Rel_converse_Rel

lemma (in arr_Rel) 
  arr_Rel_converse_Rel_converse_Rel[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: 
  "(T¯Rel)¯Rel = T"
proof(rule arr_Rel_eqI)
  from arr_Rel_axioms show "arr_Rel α ((T¯Rel)¯Rel)"
    by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: arr_Rel_axioms converse_Rel_components)

lemmas [dg_Rel_cs_simps] = 
  arr_Rel.arr_Rel_converse_Rel_converse_Rel

lemma arr_Rel_converse_Rel_eq_iff[dg_Rel_cs_simps]:
  assumes "arr_Rel α F" and "arr_Rel α G"
  shows "F¯Rel = G¯Rel ⟷ F = G"
proof(rule iffI)
  show "F¯Rel = G¯Rel ⟹ F = G"
    by (metis arr_Rel.arr_Rel_converse_Rel_converse_Rel assms)
qed simp

lemma arr_Rel_converse_Rel_comp_Rel[dg_Rel_cs_simps]:
  assumes "arr_Rel α G" and "arr_Rel α F"
  shows "(F ∘Rel G)¯Rel = G¯Rel ∘Rel F¯Rel"
proof(rule arr_Rel_eqI, unfold converse_Rel_components comp_Rel_components)
  from assms show "arr_Rel α (G¯Rel ∘Rel F¯Rel)"
    by (cs_concl cs_intro: dg_Rel_cs_intros)
  from assms show "arr_Rel α ((F ∘Rel G)¯Rel)"
    by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: vconverse_vcomp)

lemma (in 𝒵) arr_Rel_converse_Rel_id_Rel: 
  assumes "c ∈∘ Vset α"
  shows "arr_Rel α ((id_Rel c)¯Rel)"
  using assms 𝒵_axioms 
  by (cs_concl cs_intro: dg_Rel_cs_intros arr_Rel_id_RelI)+

lemma (in 𝒵) arr_Rel_converse_Rel_id_Rel_eq_id_Rel[
    dg_Rel_shared_cs_simps, dg_Rel_cs_simps
    ]: 
  assumes "c ∈∘ Vset α"
  shows "(id_Rel c)¯Rel = id_Rel c"
  by (rule arr_Rel_eqI[of α], unfold converse_Rel_components id_Rel_components)
    (simp_all add: assms arr_Rel_id_RelI arr_Rel_converse_Rel_id_Rel)

lemmas [dg_Rel_shared_cs_simps, dg_Rel_cs_simps] = 
  𝒵.arr_Rel_converse_Rel_id_Rel_eq_id_Rel

lemma arr_Rel_comp_Rel_converse_Rel_left_if_v11[dg_Rel_cs_simps]:
  assumes "arr_Rel α T" 
    and "𝒟∘ (T⦇ArrVal⦈) = A"
    and "T⦇ArrDom⦈ = A"
    and "v11 (T⦇ArrVal⦈)" 
    and "A ∈∘ Vset α"
  shows "T¯Rel ∘Rel T = id_Rel A"
proof-
  interpret T: arr_Rel α T by (rule assms(1))
  interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(4))
  show ?thesis
    by (rule arr_Rel_eqI[of α])
      (
        auto simp: 
          converse_Rel_components 
          comp_Rel_components 
          id_Rel_components 
          assms(1,3,5)
          arr_Rel.arr_Rel_converse_Rel 
          arr_Rel_comp_Rel  
          T.arr_Rel_id_RelI
          v11.v11_vcomp_vconverse[unfolded assms(2)] 
      )
qed

lemma arr_Rel_comp_Rel_converse_Rel_right_if_v11[dg_Rel_cs_simps]:
  assumes "arr_Rel α T" 
    and "ℛ∘ (T⦇ArrVal⦈) = A"
    and "T⦇ArrCod⦈ = A"
    and "v11 (T⦇ArrVal⦈)" 
    and "A ∈∘ Vset α"
  shows "T ∘Rel T¯Rel = id_Rel A"
proof-
  interpret T: arr_Rel α T by (rule assms(1))
  interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(4))
  show ?thesis
    by (rule arr_Rel_eqI[of α])
      (
        auto simp: 
          assms(1,3,5)
          comp_Rel_components 
          converse_Rel_components 
          id_Rel_components 
          v11.v11_vcomp_vconverse'[unfolded assms(2)] 
          T.arr_Rel_id_RelI 
          arr_Rel.arr_Rel_converse_Rel
          arr_Rel_comp_Rel 
      )
qed



subsection‹‹Rel› as a digraph›


subsubsection‹Definition and elementary properties›

definition dg_Rel :: "V ⇒ V"
  where "dg_Rel α =
    [
      Vset α,
      set {T. arr_Rel α T},
      (λT∈∘set {T. arr_Rel α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Rel α T}. T⦇ArrCod⦈)
    ]∘"


text‹Components.›

lemma dg_Rel_components:
  shows "dg_Rel α⦇Obj⦈ = Vset α"
    and "dg_Rel α⦇Arr⦈ = set {T. arr_Rel α T}"
    and "dg_Rel α⦇Dom⦈ = (λT∈∘set {T. arr_Rel α T}. T⦇ArrDom⦈)"
    and "dg_Rel α⦇Cod⦈ = (λT∈∘set {T. arr_Rel α T}. T⦇ArrCod⦈)"
  unfolding dg_Rel_def dg_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object›

lemma dg_Rel_Obj_iff: "x ∈∘ dg_Rel α⦇Obj⦈ ⟷ x ∈∘ Vset α" 
  unfolding dg_Rel_components by auto


subsubsection‹Arrow›

lemma dg_Rel_Arr_iff[dg_Rel_cs_simps]: "x ∈∘ dg_Rel α⦇Arr⦈ ⟷ arr_Rel α x" 
  unfolding dg_Rel_components by auto


subsubsection‹Domain›

mk_VLambda dg_Rel_components(3)
  |vsv dg_Rel_Dom_vsv[dg_Rel_cs_intros]|
  |vdomain dg_Rel_Dom_vdomain[dg_Rel_cs_simps]|
  |app dg_Rel_Dom_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|

lemma dg_Rel_Dom_vrange: "ℛ∘ (dg_Rel α⦇Dom⦈) ⊆∘ dg_Rel α⦇Obj⦈"
  unfolding dg_Rel_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto


subsubsection‹Codomain›

mk_VLambda dg_Rel_components(4)
  |vsv dg_Rel_Cod_vsv[dg_Rel_cs_intros]|
  |vdomain dg_Rel_Cod_vdomain[dg_Rel_cs_simps]|
  |app dg_Rel_Cod_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|

lemma dg_Rel_Cod_vrange: "ℛ∘ (dg_Rel α⦇Cod⦈) ⊆∘ dg_Rel α⦇Obj⦈"
  unfolding dg_Rel_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto


subsubsection‹Arrow with a domain and a codomain›


text‹Rules.›

lemma dg_Rel_is_arrI[dg_Rel_cs_intros]:
  assumes "arr_Rel α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  shows "S : A ↦dg_Rel α B"
  using assms by (intro is_arrI, unfold dg_Rel_components) simp_all

lemma dg_Rel_is_arrD:
  assumes "S : A ↦dg_Rel α B"
  shows "arr_Rel α S" 
    and [dg_cs_simps]: "S⦇ArrDom⦈ = A" 
    and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Rel_components by simp_all

lemma dg_Rel_is_arrE:
  assumes "S : A ↦dg_Rel α B"
  obtains "arr_Rel α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Rel_components by simp_all


text‹Elementary properties.›

lemma (in 𝒵) dg_Rel_incl_Rel_is_arr:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "incl_Rel A B : A ↦dg_Rel α B"
proof(rule dg_Rel_is_arrI)
  show "arr_Rel α (incl_Rel A B)" by (intro arr_Rel_incl_RelI assms)
qed (simp_all add: incl_Rel_components)

lemma (in 𝒵) dg_Rel_incl_Rel_is_arr'[dg_Rel_cs_intros]:
  assumes "A ∈∘ Vset α" 
    and "B ∈∘ Vset α" 
    and "A ⊆∘ B"
    and "A' = A"
    and "B' = B"
  shows "incl_Rel A B : A' ↦dg_Rel α B'"
  using assms(1-3) unfolding assms(4,5) by (rule dg_Rel_incl_Rel_is_arr)

lemmas [dg_Rel_cs_intros] = 𝒵.dg_Rel_incl_Rel_is_arr'


subsubsection‹‹Rel› is a digraph›

lemma (in 𝒵) dg_Rel_Hom_vifunion_in_Vset:
  assumes "X ∈∘ Vset α" and "Y ∈∘ Vset α"
  shows "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B) ∈∘ Vset α"
proof-
  define Q where
    "Q i = (if i = 0 then VPow (⋃∘X ×∘ ⋃∘Y) else if i = 1ℕ then X else Y)" 
    for i
  have 
    "{[r, A, B]∘ |r A B. r ⊆∘ ⋃∘X ×∘ ⋃∘Y ∧ A ∈∘ X ∧ B ∈∘ Y} ⊆
      elts (∏∘i∈∘ set {0, 1ℕ, 2ℕ}. Q i)"
  proof(intro subsetI, unfold mem_Collect_eq, elim exE conjE)
    fix F r A B assume prems: 
      "F = [r, A, B]∘" 
      "r ⊆∘ ⋃∘X ×∘ ⋃∘Y"
      "A ∈∘ X"
      "B ∈∘ Y"
    show "F ∈∘ (∏∘i∈∘ set {0, 1ℕ, 2ℕ}. Q i)"
    proof(intro vproductI, unfold Ball_def; (intro allI impI)?)
      show "𝒟∘ F = set {0, 1ℕ, 2ℕ}" 
        by (simp add: three prems(1) nat_omega_simps)
      fix i assume "i ∈∘ set {0, 1ℕ, 2ℕ}"
      then consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› by auto
      then show "F⦇i⦈ ∈∘ Q i" by cases (auto simp: Q_def prems nat_omega_simps)
    qed (auto simp: prems(1))
  qed
  moreover then have small[simp]: 
    "small {[r, A, B]∘ | r A B. r ⊆∘⋃∘X ×∘ ⋃∘Y ∧ A ∈∘ X ∧ B ∈∘ Y}"
    by (rule down)
  ultimately have
    "set {[r, A, B]∘ |r A B. r ⊆∘ ⋃∘X ×∘ ⋃∘Y ∧ A ∈∘ X ∧ B ∈∘ Y} ⊆∘
      (∏∘i∈∘ set {0, 1ℕ, 2ℕ}. Q i)"
    by auto
  moreover have "(∏∘i∈∘ set {0, 1ℕ, 2ℕ}. Q i) ∈∘ Vset α"
  proof(rule Limit_vproduct_in_VsetI)
    show "set {0, 1ℕ, 2ℕ} ∈∘ Vset α"
      by (auto simp: three[symmetric] intro!: Axiom_of_Infinity)
    from assms(1,2) have "VPow (⋃∘X ×∘ ⋃∘Y) ∈∘ Vset α"
      by (intro Limit_VPow_in_VsetI Limit_vtimes_in_VsetI) auto
    then show "Q i ∈∘ Vset α" if "i ∈∘ set {0, 1ℕ, 2ℕ}" for i
      using that assms(1,2) unfolding Q_def by (auto simp: nat_omega_simps)
  qed auto
  moreover have
    "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B) ⊆∘
      set {[r, A, B]∘ | r A B. r ⊆∘⋃∘X ×∘ ⋃∘Y ∧ A ∈∘ X ∧ B ∈∘ Y}"
  proof(rule vsubsetI)
    fix F assume prems: "F ∈∘ (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B)"
    then obtain A where A: "A ∈∘ X" and F_b: "F ∈∘ (⋃∘B∈∘Y. Hom (dg_Rel α) A B)" 
      unfolding vifunion_iff by auto
    then obtain B where B: "B ∈∘ Y" and F_fba: "F ∈∘ Hom (dg_Rel α) A B" 
      by fastforce
    then have "F : A ↦dg_Rel α B" by simp
    note F = dg_Rel_is_arrD[OF this]
    interpret F: arr_Rel α F rewrites "F⦇ArrDom⦈ = A" and "F⦇ArrCod⦈ = B"
      by (intro F)+
    show "F ∈∘ set {[r, A, B]∘ | r A B. r ⊆∘⋃∘X ×∘ ⋃∘Y ∧ A ∈∘ X ∧ B ∈∘ Y}"
    proof(intro in_set_CollectI small exI conjI)
      from F.arr_Rel_def show "F = [F⦇ArrVal⦈, A, B]∘" unfolding F(2,3) by simp
      from A B have "A ×∘ B ⊆∘ ⋃∘X ×∘ ⋃∘Y" by auto
      moreover then have "F⦇ArrVal⦈ ⊆∘ A ×∘ B"
        by (auto simp: F.arr_Rel_ArrVal_vsubset_ArrDom_ArrCod)
      ultimately show "F⦇ArrVal⦈ ⊆∘ ⋃∘X ×∘ ⋃∘Y" by auto
    qed (intro A B)+
  qed
  ultimately show "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B) ∈∘ Vset α" by blast
qed

lemma (in 𝒵) digraph_dg_Rel: "digraph α (dg_Rel α)"
proof(intro digraphI)
  show "vfsequence (dg_Rel α)" unfolding dg_Rel_def by clarsimp
  show "vcard (dg_Rel α) = 4ℕ" 
    unfolding dg_Rel_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dg_Rel α⦇Dom⦈) ⊆∘ dg_Rel α⦇Obj⦈" by (simp add: dg_Rel_Dom_vrange)
  show "ℛ∘ (dg_Rel α⦇Cod⦈) ⊆∘ dg_Rel α⦇Obj⦈" by (simp add: dg_Rel_Cod_vrange)
qed (auto simp: dg_Rel_components dg_Rel_Hom_vifunion_in_Vset dg_Rel_Dom_vrange)



subsection‹Canonical dagger for ‹Rel››


text‹
Dagger categories are exposed explicitly later. 
In the context of this section, the ``dagger'' is viewed merely as 
an explicitly defined homomorphism. A definition of a dagger functor, upon
which the definition presented in this section is based, can be found in nLab 
\cite{noauthor_nlab_nodate}\footnote{\url{https://ncatlab.org/nlab/show/Rel})}.
This reference also contains the majority of the results that are presented
in this subsection.
›


subsubsection‹Definition and elementary properties›

definition dghm_dag_Rel :: "V ⇒ V" (‹†DG.Rel›)
  where "†DG.Rel α = 
    [
      vid_on (dg_Rel α⦇Obj⦈), 
      VLambda (dg_Rel α⦇Arr⦈) converse_Rel, 
      op_dg (dg_Rel α), 
      dg_Rel α
    ]∘"


text‹Components.›

lemma dghm_dag_Rel_components:
  shows "†DG.Rel α⦇ObjMap⦈ = vid_on (dg_Rel α⦇Obj⦈)"
    and "†DG.Rel α⦇ArrMap⦈ = VLambda (dg_Rel α⦇Arr⦈) converse_Rel"
    and "†DG.Rel α⦇HomDom⦈ = op_dg (dg_Rel α)"
    and "†DG.Rel α⦇HomCod⦈ = dg_Rel α"
  unfolding dghm_dag_Rel_def dghm_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object map›

mk_VLambda dghm_dag_Rel_components(1)[folded VLambda_vid_on]
  |vsv dghm_dag_Rel_ObjMap_vsv[dg_Rel_cs_intros]|
  |vdomain 
    dghm_dag_Rel_ObjMap_vdomain[unfolded dg_Rel_components, dg_Rel_cs_simps]
  |
  |app dghm_dag_Rel_ObjMap_app[unfolded dg_Rel_components, dg_Rel_cs_simps]|

lemma dghm_dag_Rel_ObjMap_vrange[dg_cs_simps]: "ℛ∘ (†DG.Rel α⦇ObjMap⦈) = Vset α"
  unfolding dghm_dag_Rel_components dg_Rel_components by simp


subsubsection‹Arrow map›

mk_VLambda dghm_dag_Rel_components(2)
  |vsv dghm_dag_Rel_ArrMap_vsv[dg_Rel_cs_intros]|
  |vdomain dghm_dag_Rel_ArrMap_vdomain[dg_Rel_cs_simps]|
  |app dghm_dag_Rel_ArrMap_app[unfolded dg_Rel_cs_simps, dg_Rel_cs_simps]|


subsubsection‹Further properties›

lemma dghm_dag_Rel_ArrMap_vrange[dg_Rel_cs_simps]: 
  "ℛ∘ (†DG.Rel α⦇ArrMap⦈) = dg_Rel α⦇Arr⦈"
proof(intro vsubset_antisym vsubsetI)
  interpret ArrMap: vsv ‹†DG.Rel α⦇ArrMap⦈› 
    unfolding dghm_dag_Rel_components by simp
  fix T assume "T ∈∘ ℛ∘ (†DG.Rel α⦇ArrMap⦈)"
  then obtain S where T_def: "T = †DG.Rel α⦇ArrMap⦈⦇S⦈" 
    and S: "S ∈∘ 𝒟∘ (†DG.Rel α⦇ArrMap⦈)"
    by (blast dest: ArrMap.vrange_atD)
  from S show "T ∈∘ dg_Rel α⦇Arr⦈" 
    by 
      (
        simp add:
          T_def 
          dghm_dag_Rel_components 
          dg_Rel_components 
          arr_Rel.arr_Rel_converse_Rel
      )
next
  interpret ArrMap: vsv ‹†DG.Rel α⦇ArrMap⦈› 
    unfolding dghm_dag_Rel_components by simp
  fix T assume "T ∈∘ dg_Rel α⦇Arr⦈"
  then have "arr_Rel α T" by (simp add: dg_Rel_components)
  then have "(T¯Rel)¯Rel = T" and "arr_Rel α (T¯Rel)"
    by 
      (
        auto simp: 
          arr_Rel.arr_Rel_converse_Rel_converse_Rel arr_Rel.arr_Rel_converse_Rel
      )
  then have "†DG.Rel α⦇ArrMap⦈⦇T¯Rel⦈ = T" "T¯Rel ∈∘ 𝒟∘ (†DG.Rel α⦇ArrMap⦈)"
    by (simp_all add: dg_Rel_components(2) dghm_dag_Rel_components(2))
  then show "T ∈∘ ℛ∘ (†DG.Rel α⦇ArrMap⦈)" by blast
qed

lemma dghm_dag_Rel_ArrMap_app_is_arr:
  assumes "T : b ↦dg_Rel α a"
  shows 
    "†DG.Rel α⦇ArrMap⦈⦇T⦈ : †DG.Rel α⦇ObjMap⦈⦇a⦈ ↦dg_Rel α †DG.Rel α⦇ObjMap⦈⦇b⦈"
proof(intro is_arrI)
  from assms have a: "a ∈∘ Vset α" and b: "b ∈∘ Vset α"
    unfolding dg_Rel_components by (fastforce simp: dg_Rel_components)+
  from assms have T: "arr_Rel α T" by (auto simp: dg_Rel_is_arrD(1))
  then show dag_T: "†DG.Rel α⦇ArrMap⦈⦇T⦈ ∈∘ dg_Rel α⦇Arr⦈"
    by (cs_concl cs_simp: dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
  from a assms T show "dg_Rel α⦇Dom⦈⦇†DG.Rel α⦇ArrMap⦈⦇T⦈⦈ = †DG.Rel α⦇ObjMap⦈⦇a⦈"
    by (cs_concl cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
  from b assms T show "dg_Rel α⦇Cod⦈⦇†DG.Rel α⦇ArrMap⦈⦇T⦈⦈ = †DG.Rel α⦇ObjMap⦈⦇b⦈"
    by (cs_concl cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
qed


subsubsection‹Canonical dagger for ‹Rel› is a digraph isomorphism›

lemma (in 𝒵) dghm_dag_Rel_is_iso_dghm: 
  "†DG.Rel α : op_dg (dg_Rel α) ↦↦DG.isoα dg_Rel α"
proof(rule is_iso_dghmI)
  interpret digraph α ‹dg_Rel α› by (simp add: digraph_dg_Rel)
  show "†DG.Rel α : op_dg (dg_Rel α) ↦↦DGα dg_Rel α"
  proof(rule is_dghmI, unfold dg_op_simps dghm_dag_Rel_components(3,4))
    show "vfsequence (†DG.Rel α)"
      unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
    show "vcard (†DG.Rel α) = 4ℕ"
      unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
    fix T a b assume "T : b ↦dg_Rel α a" 
    then show
      "†DG.Rel α⦇ArrMap⦈⦇T⦈ : †DG.Rel α⦇ObjMap⦈⦇a⦈ ↦dg_Rel α †DG.Rel α⦇ObjMap⦈⦇b⦈"
      by (rule dghm_dag_Rel_ArrMap_app_is_arr)
  qed (auto simp: dghm_dag_Rel_components intro: dg_cs_intros dg_op_intros)
  show "v11 (†DG.Rel α⦇ArrMap⦈)"
  proof
    (
      intro vsv.vsv_valeq_v11I,
      unfold dghm_dag_Rel_ArrMap_vdomain dg_Rel_Arr_iff
    )
    fix S T assume prems: 
      "arr_Rel α S" 
      "arr_Rel α T" 
      "†DG.Rel α⦇ArrMap⦈⦇S⦈ = †DG.Rel α⦇ArrMap⦈⦇T⦈" 
    from prems show "S = T"
      by 
        (
          auto simp: 
            dg_Rel_components 
            dg_Rel_cs_simps
            dghm_dag_Rel_ArrMap_app[OF prems(1)] 
            dghm_dag_Rel_ArrMap_app[OF prems(2)]
        )
  qed (auto intro: dg_Rel_cs_intros)
  show "ℛ∘ (†DG.Rel α⦇ArrMap⦈) = dg_Rel α⦇Arr⦈" by (simp add: dg_Rel_cs_simps)
qed (simp_all add: dghm_dag_Rel_components)


subsubsection‹Further properties of the canonical dagger›

lemma (in 𝒵) dghm_cn_comp_dghm_dag_Rel_dghm_dag_Rel: 
  "†DG.Rel α DGHM∘ †DG.Rel α = dghm_id (dg_Rel α)"
proof-
  interpret digraph α ‹dg_Rel α› by (simp add: digraph_dg_Rel)
  from dghm_dag_Rel_is_iso_dghm have dag: 
    "†DG.Rel α : dg_Rel α DG↦↦α dg_Rel α"
    by (simp add: is_iso_dghm_def)
  show ?thesis
  proof(rule dghm_eqI)
    show "(†DG.Rel α DGHM∘ †DG.Rel α)⦇ArrMap⦈ = dghm_id (dg_Rel α)⦇ArrMap⦈"
    proof(rule vsv_eqI)
      show "vsv ((†DG.Rel α DGHM∘ †DG.Rel α)⦇ArrMap⦈)"
        by (auto simp: dghm_cn_comp_components dghm_dag_Rel_components)
      fix a assume "a ∈∘ 𝒟∘ ((†DG.Rel α DGHM∘ †DG.Rel α)⦇ArrMap⦈)"
      then have a: "arr_Rel α a" 
        unfolding dg_Rel_cs_simps dghm_cn_comp_ArrMap_vdomain[OF dag dag] by simp
      from a dghm_dag_Rel_is_iso_dghm show 
        "(†DG.Rel α DGHM∘ †DG.Rel α)⦇ArrMap⦈⦇a⦈ = dghm_id (dg_Rel α)⦇ArrMap⦈⦇a⦈"
        by
          (
            cs_concl
              cs_simp: dg_Rel_cs_simps dg_cs_simps dg_cn_cs_simps 
              cs_intro: dg_Rel_cs_intros dghm_cs_intros 
          )
    qed (simp_all add: dghm_cn_comp_components dghm_id_components dg_Rel_cs_simps)
    show "dghm_id (dg_Rel α) : dg_Rel α ↦↦DGα dg_Rel α"
      by (simp_all add: digraph.dg_dghm_id_is_dghm digraph_axioms)
  qed 
    (
      auto simp: 
        dghm_cn_comp_is_dghm[OF digraph_axioms dag dag] 
        dghm_cn_comp_components 
        dghm_dag_Rel_components 
        dghm_id_components
    )
qed

text‹\newpage›

end

Theory CZH_DG_Par

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Par› as a digraph›
theory CZH_DG_Par
  imports
    CZH_DG_Rel
    CZH_DG_Subdigraph
begin



subsection‹Background›


text‹
‹Par› is usually defined as a category of sets and partial functions
(see nLab \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/partial+function}
}).
However, there is little that can prevent one from exposing ‹Par› 
as a digraph and provide additional structure gradually in subsequent
installments of this work. Thus, in this section, ‹α›-‹Par› is defined as a
digraph of sets and partial functions in ‹Vα› 
›

named_theorems dg_Par_cs_simps
named_theorems dg_Par_cs_intros

lemmas [dg_Par_cs_simps] = dg_Rel_shared_cs_simps
lemmas [dg_Par_cs_intros] = dg_Rel_shared_cs_intros



subsection‹Arrow for ‹Par››


subsubsection‹Definition and elementary properties›

locale arr_Par = 𝒵 α + vfsequence T + ArrVal: vsv ‹T⦇ArrVal⦈› for α T +
  assumes arr_Par_length[dg_Rel_shared_cs_simps, dg_Par_cs_simps]: 
    "vcard T = 3ℕ" 
    and arr_Par_ArrVal_vdomain: "𝒟∘ (T⦇ArrVal⦈) ⊆∘ T⦇ArrDom⦈"
    and arr_Par_ArrVal_vrange: "ℛ∘ (T⦇ArrVal⦈) ⊆∘ T⦇ArrCod⦈"
    and arr_Par_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈∘ Vset α"
    and arr_Par_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈∘ Vset α"


text‹Elementary properties.›

sublocale arr_Par ⊆ arr_Rel
  by unfold_locales 
    (
      simp_all add: 
        dg_Par_cs_simps
        arr_Par_ArrVal_vdomain 
        arr_Par_ArrVal_vrange
        arr_Par_ArrDom_in_Vset 
        arr_Par_ArrCod_in_Vset
    )

lemmas (in arr_Par) [dg_Par_cs_simps] = dg_Rel_shared_cs_simps


text‹Rules.›

mk_ide rf arr_Par_def[unfolded arr_Par_axioms_def]
  |intro arr_ParI|
  |dest arr_ParD[dest]|
  |elim arr_ParE[elim!]|

lemma (in 𝒵) arr_Par_vfsequenceI: 
  assumes "vsv r" 
    and "𝒟∘ r ⊆∘ a"
    and "ℛ∘ r ⊆∘ b"
    and "a ∈∘ Vset α"
    and "b ∈∘ Vset α"
  shows "arr_Par α [r, a, b]∘"
  by (intro arr_ParI) 
    (insert assms, auto simp: arr_Rel_components nat_omega_simps)

lemma arr_Par_arr_RelI:
  assumes "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
  shows "arr_Par α T"
proof-
  interpret arr_Rel α T by (rule assms(1))
  show ?thesis
    by (intro arr_ParI)
      (
        auto simp: 
          dg_Rel_cs_simps
          assms(2)
          vfsequence_axioms 
          arr_Rel_ArrVal_vdomain 
          arr_Rel_ArrVal_vrange 
          arr_Rel_ArrDom_in_Vset 
          arr_Rel_ArrCod_in_Vset
      )
qed 

lemma arr_Par_arr_RelD:
  assumes "arr_Par α T"
  shows "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
proof-
  interpret arr_Par α T by (rule assms)
  show "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
    by (rule arr_Rel_axioms) auto
qed

lemma arr_Par_arr_RelE:
  assumes "arr_Par α T"
  obtains "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
  using assms by (auto simp: arr_Par_arr_RelD)


text‹Further elementary properties.›

lemma arr_Par_eqI:
  assumes "arr_Par α S" 
    and "arr_Par α T"
    and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
    and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
    and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
  shows "S = T"
proof(rule vsv_eqI)
  interpret S: arr_Par α S by (rule assms(1))
  interpret T: arr_Par α T by (rule assms(2))
  show "vsv S" by (rule S.vsv_axioms)
  show "vsv T" by (rule T.vsv_axioms)
  show "𝒟∘ S = 𝒟∘ T" 
    by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Par_cs_simps) 
  have dom: "𝒟∘ S = 3ℕ" by (simp add: S.vfsequence_vdomain dg_Par_cs_simps)
  show "a ∈∘ 𝒟∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a 
    by (unfold dom, elim_in_numeral, insert assms) 
      (auto simp: arr_field_simps)
qed

lemma small_arr_Par[simp]: "small {T. arr_Par α T}"
proof(rule smaller_than_small)
  show "{T. arr_Par α T} ⊆ {T. arr_Rel α T}" 
    by (simp add: Collect_mono arr_Par_arr_RelD(1))
qed simp

lemma set_Collect_arr_Par[simp]: 
  "T ∈∘ set (Collect (arr_Par α)) ⟷ arr_Par α T" 
  by auto


subsubsection‹Composition›

abbreviation (input) comp_Par :: "V ⇒ V ⇒ V" (infixl ‹∘Par› 55)
  where "comp_Par ≡ comp_Rel"

lemma arr_Par_comp_Par[dg_Par_cs_intros]:
  assumes "arr_Par α S" and "arr_Par α T"
  shows "arr_Par α (S ∘Par T)"
proof(intro arr_Par_arr_RelI)
  interpret S: arr_Par α S by (rule assms(1))
  interpret T: arr_Par α T by (rule assms(2))
  show "arr_Rel α (S ∘Par T)"
    by (auto simp: S.arr_Rel_axioms T.arr_Rel_axioms arr_Rel_comp_Rel)
  show "vsv ((S ∘Par T)⦇ArrVal⦈)"
    unfolding comp_Rel_components
    by (simp add: S.ArrVal.vsv_axioms T.ArrVal.vsv_axioms vsv_vcomp)
qed


subsubsection‹Inclusion›

abbreviation (input) incl_Par :: "V ⇒ V ⇒ V"
  where "incl_Par ≡ incl_Rel"

lemma (in 𝒵) arr_Par_incl_ParI:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "arr_Par α (incl_Par A B)"
proof(intro arr_Par_arr_RelI)
  from assms show "arr_Rel α (incl_Par A B)" 
    by (force intro: arr_Rel_incl_RelI)
qed (simp add: incl_Rel_components)


subsubsection‹Identity›

abbreviation (input) id_Par :: "V ⇒ V"
  where "id_Par ≡ id_Rel"

lemma (in 𝒵) arr_Par_id_ParI:
  assumes "A ∈∘ Vset α"
  shows "arr_Par α (id_Par A)"
  using assms
  by (intro arr_Par_arr_RelI) 
    (auto intro: arr_Rel_id_RelI simp: id_Rel_components)

lemma arr_Par_comp_Par_id_Par_left[dg_Par_cs_simps]:
  assumes "arr_Par α f" and "f⦇ArrCod⦈ = A"
  shows "id_Par A ∘Rel f = f"
proof-
  interpret f: arr_Par α f by (rule assms(1))
  have "arr_Rel α f" by (simp add: f.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_left[OF this assms(2)] show ?thesis .
qed

lemma arr_Par_comp_Par_id_Par_right[dg_Par_cs_simps]:
  assumes "arr_Par α f" and "f⦇ArrDom⦈ = A"
  shows "f ∘Rel id_Par A = f"
proof-
  interpret f: arr_Par α f by (rule assms(1))
  have "arr_Rel α f" by (simp add: f.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_right[OF this assms(2)] show ?thesis.
qed

lemma arr_Par_comp_Par_ArrVal:
  assumes "arr_Par α S" 
    and "arr_Par α T" 
    and "x ∈∘ 𝒟∘ (T⦇ArrVal⦈)"
    and "T⦇ArrVal⦈⦇x⦈ ∈∘ 𝒟∘ (S⦇ArrVal⦈)"
  shows "(S ∘Par T)⦇ArrVal⦈⦇x⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇x⦈⦈"
  using assms 
  unfolding comp_Rel_components 
  by (intro vcomp_atI) auto



subsection‹‹Par› as a digraph›


subsubsection‹Definition and elementary properties›

definition dg_Par :: "V ⇒ V"
  where "dg_Par α =
    [
      Vset α,
      set {T. arr_Par α T},
      (λT∈∘set {T. arr_Par α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Par α T}. T⦇ArrCod⦈)
    ]∘"


text‹Components.›

lemma dg_Par_components:
  shows "dg_Par α⦇Obj⦈ = Vset α"
    and "dg_Par α⦇Arr⦈ = set {T. arr_Par α T}"
    and "dg_Par α⦇Dom⦈ = (λT∈∘set {T. arr_Par α T}. T⦇ArrDom⦈)"
    and "dg_Par α⦇Cod⦈ = (λT∈∘set {T. arr_Par α T}. T⦇ArrCod⦈)"
  unfolding dg_Par_def dg_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object›

lemma dg_Par_Obj_iff: "x ∈∘ dg_Par α⦇Obj⦈ ⟷ x ∈∘ Vset α" 
  unfolding dg_Par_components by auto


subsubsection‹Arrow›

lemma dg_Par_Arr_iff[dg_Par_cs_simps]: "x ∈∘ dg_Par α⦇Arr⦈ ⟷ arr_Par α x" 
  unfolding dg_Par_components by auto


subsubsection‹Domain›

mk_VLambda dg_Par_components(3)
  |vsv dg_Par_Dom_vsv[dg_Par_cs_intros]|
  |vdomain dg_Par_Dom_vdomain[dg_Par_cs_simps]|
  |app dg_Par_Dom_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|

lemma dg_Par_Dom_vrange: "ℛ∘ (dg_Par α⦇Dom⦈) ⊆∘ dg_Par α⦇Obj⦈"
  unfolding dg_Par_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto


subsubsection‹Codomain›

mk_VLambda dg_Par_components(4)
  |vsv dg_Par_Cod_vsv[dg_Par_cs_intros]|
  |vdomain dg_Par_Cod_vdomain[dg_Par_cs_simps]|
  |app dg_Par_Cod_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|

lemma dg_Par_Cod_vrange: "ℛ∘ (dg_Par α⦇Cod⦈) ⊆∘ dg_Par α⦇Obj⦈"
  unfolding dg_Par_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto


subsubsection‹Arrow with a domain and a codomain›


text‹Rules.›

lemma dg_Par_is_arrI:
  assumes "arr_Par α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  shows "S : A ↦dg_Par α B"
  using assms by (intro is_arrI, unfold dg_Par_components) simp_all

lemmas [dg_Par_cs_intros] = dg_Par_is_arrI

lemma dg_Par_is_arrD:
  assumes "S : A ↦dg_Par α B"
  shows "arr_Par α S" 
    and [dg_cs_simps]: "S⦇ArrDom⦈ = A" 
    and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Par_components by simp_all

lemma dg_Par_is_arrE:
  assumes "S : A ↦dg_Par α B"
  obtains "arr_Par α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Par_components by simp_all


text‹Elementary properties.›

lemma dg_Par_is_arr_dg_Rel_is_arr:
  assumes "r : a ↦dg_Par α b" 
  shows "r : a ↦dg_Rel α b"
  using assms arr_Par_arr_RelD(1) 
  by (intro dg_Rel_is_arrI; elim dg_Par_is_arrE) auto

lemma dg_Par_Hom_vsubset_dg_Rel_Hom:
  assumes "a ∈∘ dg_Par α⦇Obj⦈" "b ∈∘ dg_Par α⦇Obj⦈" 
  shows "Hom (dg_Par α) a b ⊆∘ Hom (dg_Rel α) a b"
  by (rule vsubsetI) (simp add: dg_Par_is_arr_dg_Rel_is_arr)

lemma (in 𝒵) dg_Par_incl_Par_is_arr:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "incl_Par A B : A ↦dg_Par α B"
  by (rule dg_Par_is_arrI)
    (auto simp: incl_Rel_components intro!: arr_Par_incl_ParI assms)

lemma (in 𝒵) dg_Par_incl_Par_is_arr'[dg_Par_cs_intros]:
  assumes "A ∈∘ Vset α" 
    and "B ∈∘ Vset α" 
    and "A ⊆∘ B"
    and "A' = A"
    and "B' = B"
  shows "incl_Par A B : A' ↦dg_Par α B'"
  using assms(1-3) unfolding assms(4,5) by (rule dg_Par_incl_Par_is_arr)

lemmas [dg_Par_cs_intros] = 𝒵.dg_Par_incl_Par_is_arr'


subsubsection‹‹Par› is a digraph›

lemma (in 𝒵) dg_Par_Hom_vifunion_in_Vset:
  assumes "X ∈∘ Vset α" and "Y ∈∘ Vset α"
  shows "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Par α) A B) ∈∘ Vset α"
proof-
  have 
    "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Par α) A B) ⊆∘
      (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B)"
  proof(intro vsubsetI)
    fix F assume "F ∈∘ (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Par α) A B)"
    then obtain B where B: "B ∈∘ Y" and "F ∈∘ (⋃∘A∈∘X. Hom (dg_Par α) A B)" 
      by fast
    then obtain A where A: "A ∈∘ X" and F_AB: "F ∈∘ Hom (dg_Par α) A B" by fast
    from A B assms have "A ∈∘ dg_Par α⦇Obj⦈" "B ∈∘ dg_Par α⦇Obj⦈"
      unfolding dg_Par_components by auto
    from F_AB A B dg_Par_Hom_vsubset_dg_Rel_Hom[OF this] show 
      "F ∈∘ (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Rel α) A B)"
      by (intro vifunionI) (auto elim!: vsubsetE simp: in_Hom_iff) 
  qed
  with dg_Rel_Hom_vifunion_in_Vset[OF assms] show ?thesis by blast
qed

lemma (in 𝒵) digraph_dg_Par: "digraph α (dg_Par α)"
proof(intro digraphI)
  show "vfsequence (dg_Par α)" unfolding dg_Par_def by simp
  show "vcard (dg_Par α) = 4ℕ" 
    unfolding dg_Par_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dg_Par α⦇Dom⦈) ⊆∘ dg_Par α⦇Obj⦈" by (simp add: dg_Par_Dom_vrange)
  show "ℛ∘ (dg_Par α⦇Cod⦈) ⊆∘ dg_Par α⦇Obj⦈" by (simp add: dg_Par_Cod_vrange)
qed (auto simp: dg_Par_components dg_Par_Hom_vifunion_in_Vset)


subsubsection‹‹Par› is a wide subdigraph of ‹Rel››

lemma (in 𝒵) wide_subdigraph_dg_Par_dg_Rel: "dg_Par α ⊆DG.wideα dg_Rel α"
proof(intro wide_subdigraphI)
  show "dg_Par α ⊆DGα dg_Rel α"
    by (intro subdigraphI, unfold dg_Par_components)
      (
        auto simp: 
          dg_Rel_components 
          digraph_dg_Par 
          digraph_dg_Rel 
          dg_Par_is_arr_dg_Rel_is_arr
      )
qed (simp_all add: dg_Rel_components dg_Par_components)

text‹\newpage›

end

Theory CZH_DG_Set

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Set› as a digraph›
theory CZH_DG_Set
  imports CZH_DG_Par
begin



subsection‹Background›


text‹
‹Set› is usually defined as a category of sets and total functions
(see Chapter I-2 in \cite{mac_lane_categories_2010}). However, there
is little that can prevent one from exposing ‹Set› as a digraph and
provide additional structure gradually in subsequent installments of this 
work. Thus, in this section, ‹α›-‹Set› is defined as a digraph of sets 
and binary relations in the set ‹Vα›. 
›

named_theorems dg_Set_cs_simps
named_theorems dg_Set_cs_intros

lemmas [dg_Set_cs_simps] = dg_Rel_shared_cs_simps
lemmas [dg_Set_cs_intros] = dg_Rel_shared_cs_intros



subsection‹Arrow for ‹Set››


subsubsection‹Definition and elementary properties›

locale arr_Set = 𝒵 α + vfsequence T + ArrVal: vsv ‹T⦇ArrVal⦈› for α T +
  assumes arr_Set_length[dg_Rel_shared_cs_simps, dg_Set_cs_simps]: 
      "vcard T = 3ℕ" 
    and arr_Set_ArrVal_vdomain[dg_Rel_shared_cs_simps, dg_Set_cs_simps]: 
      "𝒟∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
    and arr_Set_ArrVal_vrange: "ℛ∘ (T⦇ArrVal⦈) ⊆∘ T⦇ArrCod⦈"
    and arr_Set_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈∘ Vset α"
    and arr_Set_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈∘ Vset α"

lemmas [dg_Set_cs_simps] = arr_Set.arr_Set_ArrVal_vdomain


text‹Elementary properties.›

sublocale arr_Set ⊆ arr_Par
  by unfold_locales 
    (
      simp_all add:
        dg_Set_cs_simps
        arr_Set_ArrVal_vrange arr_Set_ArrDom_in_Vset arr_Set_ArrCod_in_Vset
    )


text‹Rules.›

mk_ide rf arr_Set_def[unfolded arr_Set_axioms_def]
  |intro arr_SetI|
  |dest arr_SetD[dest]|
  |elim arr_SetE[elim!]|

lemma (in 𝒵) arr_Set_vfsequenceI: 
  assumes "vsv r" 
    and "𝒟∘ r = a"
    and "ℛ∘ r ⊆∘ b"
    and "a ∈∘ Vset α"
    and "b ∈∘ Vset α"
  shows "arr_Set α [r, a, b]∘"
  by (intro arr_SetI) 
    (insert assms, auto simp: arr_Rel_components nat_omega_simps)

lemma arr_Set_arr_ParI:
  assumes "arr_Par α T" and "𝒟∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
  shows "arr_Set α T"
proof-
  interpret arr_Par α T by (rule assms(1))
  show ?thesis
    by (intro arr_SetI)
      (
        auto simp: 
          dg_Par_cs_simps
          assms(2) 
          vfsequence_axioms 
          arr_Rel_ArrVal_vrange 
          arr_Rel_ArrDom_in_Vset 
          arr_Rel_ArrCod_in_Vset
      )
qed 

lemma arr_Set_arr_ParD:
  assumes "arr_Set α T"
  shows "arr_Par α T" and "𝒟∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
proof-
  interpret arr_Set α T by (rule assms)
  show "arr_Par α T" and "𝒟∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
    by (rule arr_Par_axioms) (auto simp: dg_Set_cs_simps)
qed

lemma arr_Set_arr_ParE:
  assumes "arr_Set α T"
  obtains "arr_Par α T" and "𝒟∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
  using assms by (auto simp: arr_Set_arr_ParD)


text‹Further elementary properties.›

lemma arr_Set_eqI:
  assumes "arr_Set α S" 
    and "arr_Set α T"
    and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
    and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
    and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
  shows "S = T"
proof-
  interpret S: arr_Set α S by (rule assms(1))
  interpret T: arr_Set α T by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ S = 3ℕ" by (simp add: S.vfsequence_vdomain dg_Set_cs_simps)
    show "a ∈∘ 𝒟∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a
      by (unfold dom, elim_in_numeral, insert assms)
        (auto simp: arr_field_simps)
  qed (auto simp: S.vfsequence_vdomain T.vfsequence_vdomain dg_Set_cs_simps) 
qed

lemma small_arr_Set[simp]: "small {T. arr_Set α T}"
proof(rule smaller_than_small)
  show "{T. arr_Set α T} ⊆ {T. arr_Par α T}" 
    by (simp add: Collect_mono arr_Set_arr_ParD(1))
qed simp

lemma set_Collect_arr_Set[simp]: 
  "T ∈∘ set (Collect (arr_Set α)) ⟷ arr_Set α T" 
  by auto


subsubsection‹Composition›


text‹See \cite{mac_lane_categories_2010}).›

abbreviation (input) comp_Set :: "V ⇒ V ⇒ V" (infixl ‹∘Set› 55)
  where "comp_Set ≡ comp_Rel"

lemma arr_Set_comp_Set[dg_Set_cs_intros]:
  assumes "arr_Set α S" and "arr_Set α T" and "ℛ∘ (T⦇ArrVal⦈) ⊆∘ 𝒟∘ (S⦇ArrVal⦈)"
  shows "arr_Set α (S ∘Set T)"
proof(intro arr_Set_arr_ParI)
  interpret S: arr_Set α S by (rule assms(1))
  interpret T: arr_Set α T by (rule assms(2))
  show "arr_Par α (S ∘Set T)"
    by (auto simp: S.arr_Par_axioms T.arr_Par_axioms arr_Par_comp_Par)
  show "𝒟∘ ((S ∘Rel T)⦇ArrVal⦈) = (S ∘Rel T)⦇ArrDom⦈"
    unfolding comp_Rel_components vdomain_vcomp_vsubset[OF assms(3)] 
    by (simp add: dg_Set_cs_simps)
qed


subsubsection‹Inclusion›

abbreviation (input) incl_Set :: "V ⇒ V ⇒ V"
  where "incl_Set ≡ incl_Rel"

lemma (in 𝒵) arr_Set_incl_SetI:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "arr_Set α (incl_Set A B)"
proof(intro arr_Set_arr_ParI)
  from assms show "arr_Par α (incl_Set A B)" 
    by (force intro: arr_Par_incl_ParI)
qed (simp add: incl_Rel_components)


subsubsection‹Identity›

abbreviation (input) id_Set :: "V ⇒ V"
  where "id_Set ≡ id_Rel"

lemma (in 𝒵) arr_Set_id_SetI:
  assumes "A ∈∘ Vset α"
  shows "arr_Set α (id_Set A)"
proof(intro arr_Set_arr_ParI)
  from assms show "arr_Par α (id_Par A)" 
    by (force intro: arr_Par_id_ParI)
qed (simp add: id_Rel_components)

lemma arr_Set_comp_Set_id_Set_left[dg_Set_cs_simps]:
  assumes "arr_Set α F" and "F⦇ArrCod⦈ = A"
  shows "id_Set A ∘Rel F = F"
proof-
  interpret F: arr_Set α F by (rule assms(1))
  have "arr_Rel α F" by (simp add: F.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_left[OF this assms(2)] show ?thesis.
qed

lemma arr_Set_comp_Set_id_Set_right[dg_Set_cs_simps]:
  assumes "arr_Set α F" and "F⦇ArrDom⦈ = A"
  shows "F ∘Rel id_Set A = F"
proof-
  interpret F: arr_Set α F by (rule assms(1))
  have "arr_Rel α F" by (simp add: F.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_right[OF this assms(2)] show ?thesis.
qed

lemma arr_Set_comp_Set_ArrVal:
  assumes "arr_Set α S" 
    and "arr_Set α T" 
    and "x ∈∘ 𝒟∘ (T⦇ArrVal⦈)"
    and "T⦇ArrVal⦈⦇x⦈ ∈∘ 𝒟∘ (S⦇ArrVal⦈)"
  shows "(S ∘Set T)⦇ArrVal⦈⦇x⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇x⦈⦈"
proof-
  interpret S: arr_Set α S + T: arr_Set α T by (simp_all add: assms(1,2))  
  from assms show ?thesis 
    unfolding comp_Rel_components by (intro vcomp_atI) auto
qed



subsection‹‹Set› as a digraph›


subsubsection‹Definition and elementary properties›

definition dg_Set :: "V ⇒ V"
  where "dg_Set α =
    [
      Vset α,
      set {T. arr_Set α T},
      (λT∈∘set {T. arr_Set α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Set α T}. T⦇ArrCod⦈)
    ]∘"


text‹Components.›

lemma dg_Set_components:
  shows "dg_Set α⦇Obj⦈ = Vset α"
    and "dg_Set α⦇Arr⦈ = set {T. arr_Set α T}"
    and "dg_Set α⦇Dom⦈ = (λT∈∘set {T. arr_Set α T}. T⦇ArrDom⦈)"
    and "dg_Set α⦇Cod⦈ = (λT∈∘set {T. arr_Set α T}. T⦇ArrCod⦈)"
  unfolding dg_Set_def dg_field_simps by (simp_all add: nat_omega_simps)


subsubsection‹Object›

lemma dg_Set_Obj_iff: "x ∈∘ dg_Set α⦇Obj⦈ ⟷ x ∈∘ Vset α" 
  unfolding dg_Set_components by auto


subsubsection‹Arrow›

lemma dg_Set_Arr_iff[dg_Set_cs_simps]: "x ∈∘ dg_Set α⦇Arr⦈ ⟷ arr_Set α x" 
  unfolding dg_Set_components by auto


subsubsection‹Domain›

mk_VLambda dg_Set_components(3)
  |vsv dg_Set_Dom_vsv[dg_Set_cs_intros]|
  |vdomain dg_Set_Dom_vdomain[dg_Set_cs_simps]|
  |app dg_Set_Dom_app[unfolded set_Collect_arr_Set, dg_Set_cs_simps]|

lemma dg_Set_Dom_vrange: "ℛ∘ (dg_Set α⦇Dom⦈) ⊆∘ dg_Set α⦇Obj⦈"
  unfolding dg_Set_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Set) auto


subsubsection‹Codomain›

mk_VLambda dg_Set_components(4)
  |vsv dg_Set_Cod_vsv[dg_Set_cs_intros]|
  |vdomain dg_Set_Cod_vdomain[dg_Set_cs_simps]|
  |app dg_Set_Cod_app[unfolded set_Collect_arr_Set, dg_Set_cs_simps]|

lemma dg_Set_Cod_vrange: "ℛ∘ (dg_Set α⦇Cod⦈) ⊆∘ dg_Set α⦇Obj⦈"
  unfolding dg_Set_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Set) auto


subsubsection‹Arrow with a domain and a codomain›


text‹Rules.›

lemma dg_Set_is_arrI[dg_Set_cs_intros]:
  assumes "arr_Set α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  shows "S : A ↦dg_Set α B"
  using assms by (intro is_arrI, unfold dg_Set_components) simp_all

lemma dg_Set_is_arrD:
  assumes "S : A ↦dg_Set α B"
  shows "arr_Set α S" 
    and [dg_cs_simps]: "S⦇ArrDom⦈ = A" 
    and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Set_components by simp_all

lemma dg_Set_is_arrE:
  assumes "S : A ↦dg_Set α B"
  obtains "arr_Set α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
  using is_arrD[OF assms] unfolding dg_Set_components by simp_all

lemma dg_Set_ArrVal_vdomain[dg_Set_cs_simps, dg_cs_simps]:
  assumes "T : A ↦dg_Set α B"
  shows "𝒟∘ (T⦇ArrVal⦈) = A"
proof-
  interpret T: arr_Set α T using assms by (auto simp: dg_Set_is_arrD)
  from assms show ?thesis by (auto simp: dg_Set_is_arrD dg_Set_cs_simps)
qed


text‹Elementary properties.›

lemma dg_Set_ArrVal_app_vrange[dg_Set_cs_intros]:
  assumes "F : A ↦dg_Set α B" and "a ∈∘ A"
  shows "F⦇ArrVal⦈⦇a⦈ ∈∘ B"
proof-
  interpret F: arr_Set α F 
    rewrites "F⦇ArrDom⦈ = A" and "F⦇ArrCod⦈ = B"
    by (intro dg_Set_is_arrD[OF assms(1)])+
  from assms F.arr_Par_ArrVal_vrange show ?thesis
    by (auto simp: F.ArrVal.vsv_vimageI2 vsubset_iff dg_Set_cs_simps)
qed

lemma dg_Set_is_arr_dg_Par_is_arr:
  assumes "T : A ↦dg_Set α B" 
  shows "T : A ↦dg_Par α B"
  using assms arr_Set_arr_ParD(1) 
  by (intro dg_Par_is_arrI; elim dg_Set_is_arrE) auto

lemma dg_Set_Hom_vsubset_dg_Par_Hom:
  assumes "a ∈∘ dg_Set α⦇Obj⦈" "b ∈∘ dg_Set α⦇Obj⦈" 
  shows "Hom (dg_Set α) a b ⊆∘ Hom (dg_Par α) a b"
  by (rule vsubsetI) (simp add: dg_Set_is_arr_dg_Par_is_arr)

lemma (in 𝒵) dg_Set_incl_Set_is_arr:
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α" and "A ⊆∘ B"
  shows "incl_Set A B : A ↦dg_Set α B"
proof(rule dg_Set_is_arrI)
  show "arr_Set α (incl_Set A B)" by (intro arr_Set_incl_SetI assms)
qed (simp_all add: incl_Rel_components)

lemma (in 𝒵) dg_Set_incl_Set_is_arr'[dg_Set_cs_intros]:
  assumes "A ∈∘ Vset α" 
    and "B ∈∘ Vset α" 
    and "A ⊆∘ B"
    and "A' = A"
    and "B' = B"
  shows "incl_Set A B : A' ↦dg_Set α B'"
  using assms(1-3) unfolding assms(4,5) by (rule dg_Set_incl_Set_is_arr)

lemmas [dg_Set_cs_intros] = 𝒵.dg_Set_incl_Set_is_arr'


subsubsection‹‹Set› is a digraph›

lemma (in 𝒵) dg_Set_Hom_vifunion_in_Vset:
  assumes "X ∈∘ Vset α" and "Y ∈∘ Vset α"
  shows "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Set α) A B) ∈∘ Vset α"
proof-
  have 
    "(⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Set α) A B) ⊆∘
      (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Par α) A B)"
  proof
    fix F assume "F ∈∘ (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Set α) A B)"
    then obtain B where B: "B ∈∘ Y" and F_b: 
      "F ∈∘ (⋃∘A∈∘X. Hom (dg_Set α) A B)" 
      by fast
    then obtain A where A: "A ∈∘ X" and F_AB: "F ∈∘ Hom (dg_Set α) A B"
      by fast
    from A B assms have "A ∈∘ dg_Set α⦇Obj⦈" "B ∈∘ dg_Set α⦇Obj⦈"
      unfolding dg_Set_components by auto
    from F_AB A B dg_Set_Hom_vsubset_dg_Par_Hom[OF this] show 
      "F ∈∘ (⋃∘A∈∘X. ⋃∘B∈∘Y. Hom (dg_Par α) A B)"
      by (intro vifunionI) (auto elim!: vsubsetE simp: in_Hom_iff) 
  qed
  with dg_Par_Hom_vifunion_in_Vset[OF assms] show ?thesis by blast
qed

lemma (in 𝒵) digraph_dg_Set: "digraph α (dg_Set α)"
proof(intro digraphI)
  show "vfsequence (dg_Set α)" unfolding dg_Set_def by simp
  show "vcard (dg_Set α) = 4ℕ"
    unfolding dg_Set_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dg_Set α⦇Dom⦈) ⊆∘ dg_Set α⦇Obj⦈" by (simp add: dg_Set_Dom_vrange)
  show "ℛ∘ (dg_Set α⦇Cod⦈) ⊆∘ dg_Set α⦇Obj⦈" by (simp add: dg_Set_Cod_vrange)
qed (auto simp: dg_Set_components dg_Set_Hom_vifunion_in_Vset)


subsubsection‹‹Set› is a wide subdigraph of ‹Par››

lemma (in 𝒵) wide_subdigraph_dg_Set_dg_Par: "dg_Set α ⊆DG.wideα dg_Par α"
proof(intro wide_subdigraphI)
  interpret Set: digraph α ‹dg_Set α› by (rule digraph_dg_Set)
  interpret Par: digraph α ‹dg_Par α› by (rule digraph_dg_Par)
  show "dg_Set α ⊆DGα dg_Par α"
  proof(intro subdigraphI, unfold dg_Set_components)
    show "F : A ↦dg_Par α B" if "F : A ↦dg_Set α B" for F A B
      using that by (rule dg_Set_is_arr_dg_Par_is_arr)
  qed (auto simp: dg_Par_components digraph_dg_Set digraph_dg_Par)
qed (simp_all add: dg_Par_components dg_Set_components)

text‹\newpage›

end

Theory CZH_DG_Conclusions

(* Copyright 2021 (C) Mihails Milehins *)

theory CZH_DG_Conclusions
  imports 
    CZH_DG_Introduction
    CZH_DG_Digraph
    CZH_DG_Small_Digraph
    CZH_DG_DGHM
    CZH_DG_Small_DGHM
    CZH_DG_TDGHM
    CZH_DG_Small_TDGHM
    CZH_DG_PDigraph
    CZH_DG_Subdigraph
    CZH_DG_Simple
    CZH_DG_GRPH
    CZH_DG_Rel
    CZH_DG_Par
    CZH_DG_Set
begin
end

Theory CZH_SMC_Introduction

(* Copyright 2021 (C) Mihails Milehins *)

chapter‹Semicategories›

section‹Introduction›
theory CZH_SMC_Introduction
  imports CZH_DG_Introduction
begin



subsection‹Background›


text‹
Many concepts that are normally associated with category theory can be 
generalized to semicategories. It is the goal of 
this chapter to expose these generalized concepts and provide the 
relevant foundations for the development of the notion of a category
in the next chapter.
›



subsection‹Preliminaries›

named_theorems smc_op_simps
named_theorems smc_op_intros

named_theorems smc_cs_simps
named_theorems smc_cs_intros

named_theorems smc_arrow_cs_intros



subsection‹CS setup for foundations›

lemmas (in 𝒵) [smc_cs_intros] = 𝒵_β

text‹\newpage›

end

Theory CZH_SMC_Semicategory

(* Copyright 2021 (C) Mihails Milehins *)

section‹Semicategory›
theory CZH_SMC_Semicategory
  imports 
    CZH_DG_Digraph
    CZH_SMC_Introduction
begin              



subsection‹Background›

lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros


subsubsection‹Slicing›


text‹
‹Slicing› is a term that is introduced in this work for the description
of the process of the conversion of more specialized mathematical objects to 
their generalizations. 

The terminology was adapted from the informal imperative
object oriented programming, where the term slicing often refers to the
process of copying an object of a subclass type to an object of a 
superclass type \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Object_slicing}
}.
However, it is important to note that the term has other meanings in 
programming and computer science.
›

definition smc_dg :: "V ⇒ V"
  where "smc_dg ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]∘"


text‹Components.›

lemma smc_dg_components[slicing_simps]:
  shows "smc_dg ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
    and "smc_dg ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
    and "smc_dg ℭ⦇Dom⦈ = ℭ⦇Dom⦈"
    and "smc_dg ℭ⦇Cod⦈ = ℭ⦇Cod⦈"
  unfolding smc_dg_def dg_field_simps by (auto simp: nat_omega_simps)


text‹Regular definitions.›

lemma smc_dg_is_arr[slicing_simps]: "f : a ↦smc_dg ℭ b ⟷ f : a ↦ℭ b"
  unfolding is_arr_def slicing_simps ..

lemmas [slicing_intros] = smc_dg_is_arr[THEN iffD2]


subsubsection‹Composition and composable arrows›


text‹
The definition of a set of ‹composable_arrs› is equivalent to the definition
of ‹composable pairs› presented on page 10 in \cite{mac_lane_categories_2010}
(see theorem ‹dg_composable_arrs'› below). 
Nonetheless, the definition is meant to be used sparingly. Normally,
the arrows are meant to be specified explicitly using the predicate 
const‹is_arr›.
›

definition Comp :: V
  where [dg_field_simps]: "Comp = 4ℕ"

abbreviation Comp_app :: "V ⇒ V ⇒ V ⇒ V" (infixl "∘Aı" 55)
  where "Comp_app ℭ a b ≡ ℭ⦇Comp⦈⦇a, b⦈∙"

definition composable_arrs :: "V ⇒ V"
  where "composable_arrs ℭ = set 
    {[g, f]∘ | g f. ∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b}"

lemma small_composable_arrs[simp]:
  "small {[g, f]∘ | g f. ∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b}"
proof(intro down[of _ ‹ℭ⦇Arr⦈ ^× 2ℕ›] subsetI)
  fix x assume "x ∈ {[g, f]∘ | g f. ∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b}"
  then obtain g f a b c 
    where x_def: "x = [g, f]∘" and "g : b ↦ℭ c"  and "f : a ↦ℭ b"
    by clarsimp
  with vfsequence_vcpower_two_vpair show "x ∈∘ ℭ⦇Arr⦈ ^× 2ℕ"
    unfolding x_def by auto
qed


text‹Rules.›

lemma composable_arrsI[smc_cs_intros]:
  assumes "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
  shows "gf ∈∘ composable_arrs ℭ"
  using assms(2,3) small_composable_arrs 
  unfolding assms(1) composable_arrs_def 
  by auto

lemma composable_arrsE[elim!]:
  assumes "gf ∈∘ composable_arrs ℭ"
  obtains g f a b c where "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
  using assms small_composable_arrs unfolding composable_arrs_def by clarsimp

lemma small_composable_arrs'[simp]:
  "small {[g, f]∘ | g f. g ∈∘ ℭ⦇Arr⦈ ∧ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈}"
proof(intro down[of _ ‹ℭ⦇Arr⦈ ^× 2ℕ›] subsetI)
  fix gf assume 
    "gf ∈{[g, f]∘ | g f. g ∈∘ ℭ⦇Arr⦈ ∧ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈}"
  then obtain g f 
    where gf_def: "gf = [g, f]∘" 
      and "g ∈∘ ℭ⦇Arr⦈" 
      and "f ∈∘ ℭ⦇Arr⦈" 
      and "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
    by clarsimp
  with vfsequence_vcpower_two_vpair show "gf ∈∘ ℭ⦇Arr⦈ ^× 2ℕ"
    unfolding gf_def by auto
qed

lemma dg_composable_arrs':
  "set {[g, f]∘ | g f. g ∈∘ ℭ⦇Arr⦈ ∧ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈} = 
    composable_arrs ℭ"
proof-
  have "{[g, f]∘ | g f. g ∈∘ ℭ⦇Arr⦈ ∧ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈} = 
    {[g, f]∘ | g f. ∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b}"
  proof(intro subset_antisym subsetI, unfold mem_Collect_eq; elim exE conjE)
    fix gf g f 
    assume gf_def: "gf = [g, f]∘" 
      and "g ∈∘ ℭ⦇Arr⦈"
      and "f ∈∘ ℭ⦇Arr⦈" 
      and gf: "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
    then obtain a b b' c where g: "g : b' ↦ℭ c" and f: "f : a ↦ℭ b" 
      by (auto intro!: is_arrI)
    moreover have "b' = b"
      unfolding is_arrD(2,3)[OF g, symmetric] is_arrD(2,3)[OF f, symmetric]
      by (rule gf)
    ultimately have "∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b" by auto
    then show "∃g f. gf = [g, f]∘ ∧ (∃a b c. g : b ↦ℭ c ∧ f : a ↦ℭ b)"
      unfolding gf_def by auto
  next
    fix gf g f a b c 
    assume gf_def: "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
    then have "g ∈∘ ℭ⦇Arr⦈" "f ∈∘ ℭ⦇Arr⦈" "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈" by auto
    then show 
      "∃g f. gf = [g, f]∘ ∧ g ∈∘ ℭ⦇Arr⦈ ∧ f ∈∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
      unfolding gf_def by auto
  qed
  then show ?thesis unfolding composable_arrs_def by auto
qed



subsection‹Definition and elementary properties›


text‹
The definition of a semicategory that is used in this work is
similar to the definition that was used in \cite{mitchell_dominion_1972}.
It is also a natural generalization of the definition of a category that is
presented in Chapter I-2 in \cite{mac_lane_categories_2010}. The generalization
is performed by omitting the identity and the axioms associated
with it. The amendments to the definitions that are associated with size 
have already been explained in the previous chapter.
›

locale semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
  assumes smc_length[smc_cs_simps]: "vcard ℭ = 5ℕ"
    and smc_digraph[slicing_intros]: "digraph α (smc_dg ℭ)"
    and smc_Comp_vdomain: "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and smc_Comp_is_arr: 
      "⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and smc_Comp_assoc[smc_cs_simps]:
      "⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"

lemmas [smc_cs_simps] =
  semicategory.smc_length
  semicategory.smc_Comp_assoc

lemma (in semicategory) smc_Comp_is_arr'[smc_cs_intros]:
  assumes "g : b ↦ℭ c"
    and "f : a ↦ℭ b"
    and "ℭ' = ℭ"
  shows "g ∘Aℭ f : a ↦ℭ' c"
  using assms(1,2) unfolding assms(3) by (rule smc_Comp_is_arr)

lemmas [smc_cs_intros] = 
  semicategory.smc_Comp_is_arr'
  semicategory.smc_Comp_is_arr

lemmas [slicing_intros] = semicategory.smc_digraph


text‹Rules.›

lemma (in semicategory) semicategory_axioms'[smc_cs_intros]:
  assumes "α' = α"
  shows "semicategory α' ℭ"
  unfolding assms by (rule semicategory_axioms)

mk_ide rf semicategory_def[unfolded semicategory_axioms_def]
  |intro semicategoryI|
  |dest semicategoryD[dest]|
  |elim semicategoryE[elim]|

lemma semicategoryI':
  assumes "𝒵 α"
    and "vfsequence ℭ"
    and "vsv (ℭ⦇Comp⦈)"
    and "vcard ℭ = 5ℕ"
    and "vsv (ℭ⦇Dom⦈)"
    and "vsv (ℭ⦇Cod⦈)"
    and "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and "⋀gf. gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and "⋀b c g a f. ⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and "⋀c d h b g a f. ⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"
    and "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and "⋀A B. ⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹
      (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
  shows "semicategory α ℭ"
  by (intro semicategoryI digraphI, unfold slicing_simps)
    (simp_all add: assms  nat_omega_simps smc_dg_def)

lemma semicategoryD':
  assumes "semicategory α ℭ"
  shows "𝒵 α"
    and "vfsequence ℭ"
    and "vsv (ℭ⦇Comp⦈)"
    and "vcard ℭ = 5ℕ"
    and "vsv (ℭ⦇Dom⦈)"
    and "vsv (ℭ⦇Cod⦈)"
    and "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and "⋀gf. gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and "⋀b c g a f. ⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and "⋀c d h b g a f. ⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"
    and "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and "⋀A B. ⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹
      (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
  by 
    (
      simp_all add: 
        semicategoryD(2-8)[OF assms] 
        digraphD[OF semicategoryD(5)[OF assms], unfolded slicing_simps]
    )

lemma semicategoryE':
  assumes "semicategory α ℭ"
  obtains "𝒵 α"
    and "vfsequence ℭ"
    and "vsv (ℭ⦇Comp⦈)"
    and "vcard ℭ = 5ℕ"
    and "vsv (ℭ⦇Dom⦈)"
    and "vsv (ℭ⦇Cod⦈)"
    and "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and "⋀gf. gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and "⋀b c g a f. ⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and "⋀c d h b g a f. ⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"
    and "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and "⋀A B. ⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹
      (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
  using assms by (simp add: semicategoryD')


text‹
While using the sublocale infrastructure in conjunction with the rewrite 
morphisms is plausible for achieving automation of slicing, this approach
has certain limitations. For example, the rewrite morphisms cannot be added to a 
given interpretation that was achieved using the
command @{command sublocale}\footnote{
\url{
https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2019-September/msg00074.html
}
}.
Thus, instead of using a partial solution based on the command 
@{command sublocale}, the rewriting is performed manually for 
selected theorems. However, it is hoped that better automation will be provided
in the future.
›

context semicategory
begin

interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)

sublocale Dom: vsv ‹ℭ⦇Dom⦈› by (rule dg.Dom.vsv_axioms[unfolded slicing_simps])
sublocale Cod: vsv ‹ℭ⦇Cod⦈› by (rule dg.Cod.vsv_axioms[unfolded slicing_simps])

lemmas_with [unfolded slicing_simps]:
  smc_Dom_vdomain[smc_cs_simps] = dg.dg_Dom_vdomain
  and smc_Dom_vrange = dg.dg_Dom_vrange
  and smc_Cod_vdomain[smc_cs_simps] = dg.dg_Cod_vdomain
  and smc_Cod_vrange = dg.dg_Cod_vrange
  and smc_Obj_vsubset_Vset = dg.dg_Obj_vsubset_Vset
  and smc_Hom_vifunion_in_Vset[smc_cs_intros] = dg.dg_Hom_vifunion_in_Vset
  and smc_Obj_if_Dom_vrange = dg.dg_Obj_if_Dom_vrange
  and smc_Obj_if_Cod_vrange = dg.dg_Obj_if_Cod_vrange
  and smc_is_arrD = dg.dg_is_arrD
  and smc_is_arrE[elim] = dg.dg_is_arrE
  and smc_in_ArrE[elim] = dg.dg_in_ArrE
  and smc_Hom_in_Vset[smc_cs_intros] = dg.dg_Hom_in_Vset
  and smc_Arr_vsubset_Vset = dg.dg_Arr_vsubset_Vset
  and smc_Dom_vsubset_Vset = dg.dg_Dom_vsubset_Vset
  and smc_Cod_vsubset_Vset = dg.dg_Cod_vsubset_Vset
  and smc_Obj_in_Vset = dg.dg_Obj_in_Vset
  and smc_in_Obj_in_Vset[smc_cs_intros] = dg.dg_in_Obj_in_Vset
  and smc_Arr_in_Vset = dg.dg_Arr_in_Vset
  and smc_in_Arr_in_Vset[smc_cs_intros] = dg.dg_in_Arr_in_Vset
  and smc_Dom_in_Vset = dg.dg_Dom_in_Vset
  and smc_Cod_in_Vset = dg.dg_Cod_in_Vset
  and smc_digraph_if_ge_Limit = dg.dg_digraph_if_ge_Limit
  and smc_Dom_app_in_Obj = dg.dg_Dom_app_in_Obj
  and smc_Cod_app_in_Obj = dg.dg_Cod_app_in_Obj
  and smc_Arr_vempty_if_Obj_vempty = dg.dg_Arr_vempty_if_Obj_vempty
  and smc_Dom_vempty_if_Arr_vempty = dg.dg_Dom_vempty_if_Arr_vempty
  and smc_Cod_vempty_if_Arr_vempty = dg.dg_Cod_vempty_if_Arr_vempty

end

lemmas [smc_cs_intros] =
  semicategory.smc_is_arrD(1-3)
  semicategory.smc_Hom_in_Vset


text‹Elementary properties.›

lemma smc_eqI:
  assumes "semicategory α 𝔄" 
    and "semicategory α 𝔅"
    and "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
    and "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
    and "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
    and "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
    and "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
  interpret 𝔅: semicategory α 𝔅 by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ 𝔄 = 5ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
    show "𝒟∘ 𝔄 = 𝒟∘ 𝔅" by (cs_concl cs_simp: dom smc_cs_simps V_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔄 ⟹ 𝔄⦇a⦈ = 𝔅⦇a⦈" for a 
      by (unfold dom, elim_in_numeral, insert assms) (auto simp: dg_field_simps)
  qed auto
qed

lemma smc_dg_eqI:
  assumes "semicategory α 𝔄"
    and "semicategory α 𝔅"
    and "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
    and "smc_dg 𝔄 = smc_dg 𝔅"
  shows "𝔄 = 𝔅"
proof(rule smc_eqI)
  from assms(4) have 
    "smc_dg 𝔄⦇Obj⦈ = smc_dg 𝔅⦇Obj⦈"
    "smc_dg 𝔄⦇Arr⦈ = smc_dg 𝔅⦇Arr⦈"
    "smc_dg 𝔄⦇Dom⦈ = smc_dg 𝔅⦇Dom⦈"
    "smc_dg 𝔄⦇Cod⦈ = smc_dg 𝔅⦇Cod⦈" 
    by auto
  then show
    "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈" "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
    unfolding slicing_simps by simp_all
qed (auto intro: assms)

lemma (in semicategory) smc_def: "ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ ℭ = 5ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
  have dom_rhs: "𝒟∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]∘ = 5ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ ℭ = 𝒟∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]∘"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ ℭ ⟹ ℭ⦇a⦈ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]∘⦇a⦈" 
    for a
    unfolding dom_lhs
    by elim_in_numeral (simp_all add: dg_field_simps nat_omega_simps)
qed auto

lemma (in semicategory) smc_Comp_vdomainI[smc_cs_intros]: 
  assumes "g : b ↦ℭ c" and "f : a ↦ℭ b" and "gf = [g, f]∘"
  shows "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈)"
  using assms by (intro smc_Comp_vdomain[THEN iffD2]) auto

lemmas [smc_cs_intros] = semicategory.smc_Comp_vdomainI

lemma (in semicategory) smc_Comp_vdomainE[elim!]: 
  assumes "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈)" 
  obtains g f a b c where "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
proof-
  from smc_Comp_vdomain[THEN iffD1, OF assms(1)] obtain g f b c a
    where "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
    by clarsimp
  with that show ?thesis by simp
qed

lemma (in semicategory) smc_Comp_vdomain_is_composable_arrs: 
  "𝒟∘ (ℭ⦇Comp⦈) = composable_arrs ℭ"
  by (intro vsubset_antisym vsubsetI) (auto intro!: smc_cs_intros)+

lemma (in semicategory) smc_Comp_vrange: "ℛ∘ (ℭ⦇Comp⦈) ⊆∘ ℭ⦇Arr⦈"
proof(rule Comp.vsv_vrange_vsubset)
  fix gf assume "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈)"
  from smc_Comp_vdomain[THEN iffD1, OF this] obtain g f b c a
    where gf_def: "gf = [g, f]∘" 
      and g: "g : b ↦ℭ c" 
      and f: "f : a ↦ℭ b"  
    by clarsimp
  from semicategory_axioms g f show "ℭ⦇Comp⦈⦇gf⦈ ∈∘ ℭ⦇Arr⦈"
    by (cs_concl cs_simp: gf_def smc_cs_simps cs_intro: smc_cs_intros)
qed

sublocale semicategory ⊆ Comp: pbinop ‹ℭ⦇Arr⦈› ‹ℭ⦇Comp⦈›
proof unfold_locales
  show "𝒟∘ (ℭ⦇Comp⦈) ⊆∘ ℭ⦇Arr⦈ ^× 2ℕ"
  proof(intro vsubsetI; unfold smc_Comp_vdomain)
    fix gf assume "∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b"
    then obtain a b c g f 
      where x_def: "gf = [g, f]∘" and "g : b ↦ℭ c" and "f : a ↦ℭ b"
      by auto
    then have "g ∈∘ ℭ⦇Arr⦈" "f ∈∘ ℭ⦇Arr⦈" by auto
    then show "gf ∈∘ ℭ⦇Arr⦈ ^× 2ℕ" 
      unfolding x_def by (auto simp: nat_omega_simps)
  qed
  show "ℛ∘ (ℭ⦇Comp⦈) ⊆∘ ℭ⦇Arr⦈" by (rule smc_Comp_vrange)
qed auto


text‹Size.›

lemma (in semicategory) smc_Comp_vsubset_Vset: "ℭ⦇Comp⦈ ⊆∘ Vset α"
proof(intro vsubsetI)
  fix gfh assume "gfh ∈∘ ℭ⦇Comp⦈"
  then obtain gf h 
    where gfh_def: "gfh = ⟨gf, h⟩" 
      and gf: "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈)" 
      and h: "h ∈∘ ℛ∘ (ℭ⦇Comp⦈)"
    by (blast elim: Comp.vbrelation_vinE)
  from gf obtain g f a b c
    where gf_def: "gf = [g, f]∘" and g: "g : b ↦ℭ c" and f: "f : a ↦ℭ b"  
    by clarsimp
  from h smc_Comp_vrange have "h ∈∘ ℭ⦇Arr⦈" by auto
  with g f show "gfh ∈∘ Vset α"
    unfolding gfh_def gf_def 
    by (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed

lemma (in semicategory) smc_semicategory_in_Vset_4: "ℭ ∈∘ Vset (α + 4ℕ)"
proof-
  note [folded VPow_iff, folded Vset_succ[OF Ord_α], smc_cs_intros] =
    smc_Obj_vsubset_Vset
    smc_Arr_vsubset_Vset
    smc_Dom_vsubset_Vset
    smc_Cod_vsubset_Vset
    smc_Comp_vsubset_Vset
  show ?thesis
    by (subst smc_def, succ_of_numeral)
      (
        cs_concl 
          cs_simp: plus_V_succ_right V_cs_simps 
          cs_intro: smc_cs_intros V_cs_intros
      )
qed

lemma (in semicategory) smc_Comp_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ⦇Comp⦈ ∈∘ Vset β"
  using smc_Comp_vsubset_Vset by (meson Vset_in_mono assms(2) vsubset_in_VsetI)

lemma (in semicategory) smc_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "ℭ ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [smc_cs_intros] = 
    smc_Obj_in_Vset 
    smc_Arr_in_Vset
    smc_Dom_in_Vset
    smc_Cod_in_Vset
    smc_Comp_in_Vset
  from assms(2) show ?thesis 
    by (subst smc_def) (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed

lemma (in semicategory) smc_semicategory_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "semicategory β ℭ"
  by (rule semicategoryI)
    (
      auto 
        intro: smc_cs_intros 
        simp: smc_cs_simps assms vfsequence_axioms smc_digraph_if_ge_Limit 
    )

lemma small_semicategory[simp]: "small {ℭ. semicategory α ℭ}"
proof(cases ‹𝒵 α›)
  case True
  from semicategory.smc_in_Vset[of α] show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›]) 
      (auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{ℭ. semicategory α ℭ} = {}" by auto
  then show ?thesis by simp
qed

lemma (in 𝒵) semicategories_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "set {ℭ. semicategory α ℭ} ∈∘ Vset β"
proof(rule vsubset_in_VsetI)
  interpret β: 𝒵 β by (rule assms(1))
  show "set {ℭ. semicategory α ℭ} ⊆∘ Vset (α + 4ℕ)"
  proof(intro vsubsetI)
    fix ℭ assume prems: "ℭ ∈∘ set {ℭ. semicategory α ℭ}"
    interpret semicategory α ℭ using prems by simp
    show "ℭ ∈∘ Vset (α + 4ℕ)"
      unfolding VPow_iff by (rule smc_semicategory_in_Vset_4)
  qed
  from assms(2) show "Vset (α + 4ℕ) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed

lemma semicategory_if_semicategory:
  assumes "semicategory β ℭ"
    and "𝒵 α"
    and "ℭ⦇Obj⦈ ⊆∘ Vset α"
    and "⋀A B. ⟦ A ⊆∘ ℭ⦇Obj⦈; B ⊆∘ ℭ⦇Obj⦈; A ∈∘ Vset α; B ∈∘ Vset α ⟧ ⟹
      (⋃∘a∈∘A. ⋃∘b∈∘B. Hom ℭ a b) ∈∘ Vset α"
  shows "semicategory α ℭ"
proof-
  interpret semicategory β ℭ by (rule assms(1))
  interpret α: 𝒵 α by (rule assms(2))
  show ?thesis
  proof(intro semicategoryI)
    show "vfsequence ℭ" by (simp add: vfsequence_axioms)
    show "digraph α (smc_dg ℭ)"
      by (rule digraph_if_digraph, unfold slicing_simps)
        (auto intro!: assms(1,3,4) slicing_intros)
  qed (auto intro: smc_cs_intros simp: smc_cs_simps)
qed


text‹Further elementary properties.›

lemma (in semicategory) smc_Comp_vempty_if_Arr_vempty:
  assumes "ℭ⦇Arr⦈ = 0"
  shows "ℭ⦇Comp⦈ = 0"
  using assms smc_Comp_vrange by (auto intro: Comp.vsv_vrange_vempty)



subsection‹Opposite semicategory›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›

definition op_smc :: "V ⇒ V"
  where "op_smc ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Cod⦈, ℭ⦇Dom⦈, fflip (ℭ⦇Comp⦈)]∘"


text‹Components.›

lemma op_smc_components:
  shows [smc_op_simps]: "op_smc ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
    and [smc_op_simps]: "op_smc ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
    and [smc_op_simps]: "op_smc ℭ⦇Dom⦈ = ℭ⦇Cod⦈"
    and [smc_op_simps]: "op_smc ℭ⦇Cod⦈ = ℭ⦇Dom⦈"
    and "op_smc ℭ⦇Comp⦈ = fflip (ℭ⦇Comp⦈)"
  unfolding op_smc_def dg_field_simps by (auto simp: nat_omega_simps)

lemma op_smc_component_intros[smc_op_intros]:
  shows "a ∈∘ ℭ⦇Obj⦈ ⟹ a ∈∘ op_smc ℭ⦇Obj⦈"
    and "f ∈∘ ℭ⦇Arr⦈ ⟹ f ∈∘ op_smc ℭ⦇Arr⦈"
  unfolding smc_op_simps by simp_all


text‹Slicing.›

lemma op_dg_smc_dg[slicing_commute]: "op_dg (smc_dg ℭ) = smc_dg (op_smc ℭ)"
  unfolding smc_dg_def op_smc_def op_dg_def dg_field_simps
  by (simp add: nat_omega_simps)


text‹Regular definitions.›

lemma op_smc_Comp_vdomain[smc_op_simps]: 
  "𝒟∘ (op_smc ℭ⦇Comp⦈) = (𝒟∘ (ℭ⦇Comp⦈))¯∙"
  unfolding op_smc_components by simp

lemma op_smc_is_arr[smc_op_simps]: "f : b ↦op_smc ℭ a ⟷ f : a ↦ℭ b"
  unfolding smc_op_simps is_arr_def by auto

lemmas [smc_op_intros] = op_smc_is_arr[THEN iffD2]

lemma (in semicategory) op_smc_Comp_vrange[smc_op_simps]: 
  "ℛ∘ (op_smc ℭ⦇Comp⦈) = ℛ∘ (ℭ⦇Comp⦈)"
  using Comp.vrange_fflip unfolding op_smc_components by simp

lemmas [smc_op_simps] = semicategory.op_smc_Comp_vrange

lemma (in semicategory) op_smc_Comp[smc_op_simps]: 
  assumes "f : b ↦ℭ c" and "g : a ↦ℭ b"
  shows "g ∘Aop_smc ℭ f = f ∘Aℭ g"
  using assms 
  unfolding op_smc_components 
  by (auto intro!: fflip_app smc_cs_intros)

lemmas [smc_op_simps] = semicategory.op_smc_Comp

lemma op_smc_Hom[smc_op_simps]: "Hom (op_smc ℭ) a b = Hom ℭ b a"
  unfolding smc_op_simps by simp


subsubsection‹Further properties›

lemma (in semicategory) semicategory_op[smc_op_intros]: 
  "semicategory α (op_smc ℭ)"
proof(intro semicategoryI)
  from semicategory_axioms smc_digraph show "digraph α (smc_dg (op_smc ℭ))"
    by (cs_concl cs_simp: slicing_commute[symmetric] cs_intro: dg_op_intros)
  show "vfsequence (op_smc ℭ)" unfolding op_smc_def by simp
  show "vcard (op_smc ℭ) = 5ℕ"
    unfolding op_smc_def by (simp add: nat_omega_simps)
  show "(gf ∈∘ 𝒟∘ (op_smc ℭ⦇Comp⦈)) ⟷
    (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦op_smc ℭ c ∧ f : a ↦op_smc ℭ b)"
    for gf
  proof(rule iffI; unfold smc_op_simps)
    assume prems: "gf ∈∘ (𝒟∘ (ℭ⦇Comp⦈))¯∙"
    then obtain g' f' where gf_def: "gf = [g', f']∘" by clarsimp
    with prems have "[f', g']∘ ∈∘ 𝒟∘ (ℭ⦇Comp⦈)" by (auto intro: smc_cs_intros)
    with smc_Comp_vdomain show 
      "∃g f b c a. gf = [g, f]∘ ∧ g : c ↦ℭ b ∧ f : b ↦ℭ a"
      unfolding gf_def by auto
  next
    assume "∃g f b c a. gf = [g, f]∘ ∧ g : c ↦ℭ b ∧ f : b ↦ℭ a"
    then obtain g f b c a 
      where gf_def: "gf = [g, f]∘" and g: "g : c ↦ℭ b" and f: "f : b ↦ℭ a"
      by clarsimp
    then have "g ∈∘ ℭ⦇Arr⦈" and "f ∈∘ ℭ⦇Arr⦈" by force+
    from g f have "[f, g]∘ ∈∘ 𝒟∘ (ℭ⦇Comp⦈)"
      unfolding gf_def by (intro smc_Comp_vdomainI) auto
    then show "gf ∈∘ (𝒟∘ (ℭ⦇Comp⦈))¯∙" 
      unfolding gf_def by (auto intro: smc_cs_intros)
  qed
  from semicategory_axioms show 
    "⟦ g : b ↦op_smc ℭ c; f : a ↦op_smc ℭ b ⟧ ⟹ 
      g ∘Aop_smc ℭ f : a ↦op_smc ℭ c"
    for g b c f a
    unfolding smc_op_simps 
    by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros)
  fix h c d g b f a
  assume "h : c ↦op_smc ℭ d" "g : b ↦op_smc ℭ c" "f : a ↦op_smc ℭ b"
  with semicategory_axioms show
    "(h ∘Aop_smc ℭ g) ∘Aop_smc ℭ f = h ∘Aop_smc ℭ (g ∘Aop_smc ℭ f)"
    unfolding smc_op_simps
    by (cs_concl cs_simp: smc_op_simps smc_cs_simps cs_intro: smc_cs_intros)
qed (auto simp: fflip_vsv op_smc_components(5))

lemmas semicategory_op[smc_op_intros] = semicategory.semicategory_op

lemma (in semicategory) smc_op_smc_op_smc[smc_op_simps]: "op_smc (op_smc ℭ) = ℭ"
  by (rule smc_eqI, unfold smc_op_simps op_smc_components)
    (
      auto simp: 
        Comp.pbinop_fflip_fflip 
        semicategory_axioms
        semicategory.semicategory_op semicategory_op
        intro: smc_cs_intros
    )

lemmas smc_op_smc_op_smc[smc_op_simps] = semicategory.smc_op_smc_op_smc

lemma eq_op_smc_iff[smc_op_simps]: 
  assumes "semicategory α 𝔄" and "semicategory α 𝔅"
  shows "op_smc 𝔄 = op_smc 𝔅 ⟷ 𝔄 = 𝔅"
proof
  interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
  interpret 𝔅: semicategory α 𝔅 by (rule assms(2))
  assume prems: "op_smc 𝔄 = op_smc 𝔅" show "𝔄 = 𝔅"
  proof(rule smc_eqI)
    show 
      "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" 
      "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
      "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" 
      "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
      "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
      by (metis prems 𝔄.smc_op_smc_op_smc 𝔅.smc_op_smc_op_smc)+
  qed (auto intro: assms)
qed auto



subsection‹Arrow with a domain and a codomain›

lemma (in semicategory) smc_assoc_helper:
  assumes "f : a ↦ℭ b"
    and "g : b ↦ℭ c"
    and "h : c ↦ℭ d"
    and "q : b ↦ℭ d"
    and "h ∘Aℭ g = q"
  shows "h ∘Aℭ (g ∘Aℭ f) = q ∘Aℭ f"
  using semicategory_axioms assms(1-4)
  by (cs_concl cs_simp: semicategory.smc_Comp_assoc[symmetric] assms(5))

lemma (in semicategory) smc_pattern_rectangle_right:
  assumes "aa' : a ↦ℭ a'" 
    and "a'a'' : a' ↦ℭ a''"
    and "a''b'' : a'' ↦ℭ b''"
    and "ab : a ↦ℭ b"
    and "bb' : b ↦ℭ b'"
    and "b'b'' : b' ↦ℭ b''"
    and "a'b' : a' ↦ℭ b'"
    and "a'b' ∘Aℭ aa' = bb' ∘Aℭ ab"
    and "b'b'' ∘Aℭ a'b' = a''b'' ∘Aℭ a'a''"
  shows "a''b'' ∘Aℭ (a'a'' ∘Aℭ aa') = (b'b'' ∘Aℭ bb') ∘Aℭ ab"
proof-
  from semicategory_axioms assms(3,2,1) have 
    "a''b'' ∘Aℭ (a'a'' ∘Aℭ aa') = (a''b'' ∘Aℭ a'a'') ∘Aℭ aa'"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  also have "… = (b'b'' ∘Aℭ a'b') ∘Aℭ aa'" unfolding assms(9) ..
  also from semicategory_axioms assms(1,6,7) have 
    "… = b'b'' ∘Aℭ (a'b' ∘Aℭ aa')"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  also have "… = b'b'' ∘Aℭ (bb' ∘Aℭ ab)" unfolding assms(8) ..
  also from semicategory_axioms assms(6,5,4) have 
    "… = (b'b'' ∘Aℭ bb') ∘Aℭ ab" 
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  finally show ?thesis by simp
qed

lemmas (in semicategory) smc_pattern_rectangle_left = 
  smc_pattern_rectangle_right[symmetric]



subsection‹Monic arrow and epic arrow›


text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›

definition is_monic_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_monic_arr ℭ b c m ⟷
    m : b ↦ℭ c ∧
    (
      ∀f g a.
        f : a ↦ℭ b ⟶ g : a ↦ℭ b ⟶ m ∘Aℭ f = m ∘Aℭ g ⟶ f = g
    )"

syntax "_is_monic_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹_ : _ ↦monı _› [51, 51, 51] 51)
translations "m : b ↦monℭ c" ⇌ "CONST is_monic_arr ℭ b c m"

definition is_epic_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_epic_arr ℭ a b e ≡ e : b ↦monop_smc ℭ a"

syntax "_is_epic_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹_ : _ ↦epiı _› [51, 51, 51] 51)
translations "e : a ↦epiℭ b" ⇌ "CONST is_epic_arr ℭ a b e"


text‹Rules.›

mk_ide rf is_monic_arr_def
  |intro is_monic_arrI|
  |dest is_monic_arrD[dest]|
  |elim is_monic_arrE[elim!]|

lemmas [smc_arrow_cs_intros] = is_monic_arrD(1)

lemma (in semicategory) is_epic_arrI:
  assumes "e : a ↦ℭ b"
    and "⋀f g c. ⟦ f : b ↦ℭ c; g : b ↦ℭ c; f ∘Aℭ e = g ∘Aℭ e ⟧ ⟹
      f = g"
  shows "e : a ↦epiℭ b"
  unfolding is_epic_arr_def
proof(intro is_monic_arrI, unfold smc_op_simps)
  fix f g a 
  assume prems:
    "f : b ↦ℭ a" "g : b ↦ℭ a" "e ∘Aop_smc ℭ f = e ∘Aop_smc ℭ g"
  show "f = g"
  proof-
    from prems(3,1,2) assms(1) semicategory_axioms have "g ∘Aℭ e = f ∘Aℭ e"
      by 
        (
          cs_prems 
            cs_simp: smc_cs_simps smc_op_simps
            cs_intro: smc_cs_intros smc_op_intros
        )
      simp
    from assms(2)[OF prems(2,1) this] show ?thesis ..
  qed
qed (rule assms(1))

lemma is_epic_arr_is_arr[smc_arrow_cs_intros, dest]:
  assumes "e : a ↦epiℭ b"
  shows "e : a ↦ℭ b"
  using assms unfolding is_epic_arr_def is_monic_arr_def smc_op_simps by simp

lemma (in semicategory) is_epic_arrD[dest]:
  assumes "e : a ↦epiℭ b"
  shows "e : a ↦ℭ b"
    and "⋀f g c. ⟦ f : b ↦ℭ c; g : b ↦ℭ c; f ∘Aℭ e = g ∘Aℭ e ⟧ ⟹
      f = g"
proof-
  note is_monic_arrD = 
    assms(1)[unfolded is_epic_arr_def is_monic_arr_def smc_op_simps] 
  from is_monic_arrD[THEN conjunct1] show e: "e : a ↦ℭ b" by simp
  fix f g c 
  assume prems: "f : b ↦ℭ c" "g : b ↦ℭ c" "f ∘Aℭ e = g ∘Aℭ e"
  with semicategory_axioms e have "e ∘Aop_smc ℭ f = e ∘Aop_smc ℭ g"
    by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros)
  then show "f = g" 
    by (rule is_monic_arrD[THEN conjunct2, rule_format, OF prems(1,2)])
qed

lemma (in semicategory) is_epic_arrE[elim!]:
  assumes "e : a ↦epiℭ b"
  obtains "e : a ↦ℭ b"
    and "⋀f g c. ⟦ f : b ↦ℭ c; g : b ↦ℭ c; f ∘Aℭ e = g ∘Aℭ e ⟧ ⟹ 
      f = g"
  using assms by auto


text‹Elementary properties.›

lemma (in semicategory) op_smc_is_epic_arr[smc_op_simps]: 
  "f : b ↦epiop_smc ℭ a ⟷ f : a ↦monℭ b"
  unfolding is_monic_arr_def is_epic_arr_def smc_op_simps ..

lemma (in semicategory) op_smc_is_monic_arr[smc_op_simps]: 
  "f : b ↦monop_smc ℭ a ⟷ f : a ↦epiℭ b"
  unfolding is_monic_arr_def is_epic_arr_def smc_op_simps ..

lemma (in semicategory) smc_Comp_is_monic_arr[smc_arrow_cs_intros]:
  assumes "g : b ↦monℭ c" and "f : a ↦monℭ b"
  shows "g ∘Aℭ f : a ↦monℭ c"
proof(intro is_monic_arrI)
  from assms show "g ∘Aℭ f : a ↦ℭ c" by (auto intro: smc_cs_intros)
  fix f' g' a'
  assume f': "f' : a' ↦ℭ a"
    and g': "g' : a' ↦ℭ a"
    and "g ∘Aℭ f ∘Aℭ f' = g ∘Aℭ f ∘Aℭ g'"
  with assms have "g ∘Aℭ (f ∘Aℭ f') = g ∘Aℭ (f ∘Aℭ g')"
    by (force simp: smc_Comp_assoc)
  moreover from assms have "f ∘Aℭ f' : a' ↦ℭ b" "f ∘Aℭ g' : a' ↦ℭ b" 
    by (auto intro: f' g' smc_cs_intros)
  ultimately have "f ∘Aℭ f' = f ∘Aℭ g'" using assms(1) by clarsimp
  with assms f' g' show "f' = g'" by clarsimp
qed

lemmas [smc_arrow_cs_intros] = semicategory.smc_Comp_is_monic_arr

lemma (in semicategory) smc_Comp_is_epic_arr[smc_arrow_cs_intros]: 
  assumes "g : b ↦epiℭ c" and "f : a ↦epiℭ b"
  shows "g ∘Aℭ f : a ↦epiℭ c"
proof-
  from assms op_smc_is_arr have "g : b ↦ℭ c" "f : a ↦ℭ b" 
    unfolding is_epic_arr_def by auto
  with semicategory_axioms have "f ∘Aop_smc ℭ g = g ∘Aℭ f"
    by (cs_concl cs_simp: smc_op_simps)
  with 
    semicategory.smc_Comp_is_monic_arr[
      OF semicategory_op,
      OF assms(2,1)[unfolded is_epic_arr_def],
      folded is_epic_arr_def
      ]
  show ?thesis    
    by auto
qed

lemmas [smc_arrow_cs_intros] = semicategory.smc_Comp_is_epic_arr

lemma (in semicategory) smc_Comp_is_monic_arr_is_monic_arr:
  assumes "g : b ↦ℭ c" and "f : a ↦ℭ b" and "g ∘Aℭ f : a ↦monℭ c"
  shows "f : a ↦monℭ b"
proof(intro is_monic_arrI)
  fix f' g' a'
  assume f': "f' : a' ↦ℭ a" 
    and g': "g' : a' ↦ℭ a" 
    and f'gg'g: "f ∘Aℭ f' = f ∘Aℭ g'"
  from assms(1,2) f' g' have "(g ∘Aℭ f) ∘Aℭ f' = (g ∘Aℭ f) ∘Aℭ g'"
    by (auto simp: smc_Comp_assoc f'gg'g)
  with assms(3) f' g' show "f' = g'" by clarsimp
qed (simp add: assms(2))

lemma (in semicategory) smc_Comp_is_epic_arr_is_epic_arr:
  assumes "g : a ↦ℭ b" and "f : b ↦ℭ c" and "f ∘Aℭ g : a ↦epiℭ c"
  shows "f : b ↦epiℭ c"
proof-
  from assms have "g : b ↦op_smc ℭ a" "f : c ↦op_smc ℭ b" 
    unfolding smc_op_simps by simp_all 
  moreover from semicategory_axioms assms have "g ∘Aop_smc ℭ f : a ↦epiℭ c"
    by (cs_concl cs_simp: smc_op_simps)
  ultimately show ?thesis 
    using 
      semicategory.smc_Comp_is_monic_arr_is_monic_arr[
        OF semicategory_op, folded is_epic_arr_def
        ]
    by auto
qed



subsection‹Idempotent arrow›


text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›

definition is_idem_arr :: "V ⇒ V ⇒ V ⇒ bool"
  where "is_idem_arr ℭ b f ⟷ f : b ↦ℭ b ∧ f ∘Aℭ f = f"

syntax "_is_idem_arr" :: "V ⇒ V ⇒ V ⇒ bool" (‹_ : ↦ideı _› [51, 51] 51)
translations "f : ↦ideℭ b" ⇌ "CONST is_idem_arr ℭ b f"


text‹Rules.›

mk_ide rf is_idem_arr_def
  |intro is_idem_arrI|
  |dest is_idem_arrD[dest]|
  |elim is_idem_arrE[elim!]|

lemmas [smc_cs_simps] = is_idem_arrD(2)


text‹Elementary properties.›

lemma (in semicategory) op_smc_is_idem_arr[smc_op_simps]: 
  "f : ↦ideop_smc ℭ b ⟷ f : ↦ideℭ b"
  using op_smc_Comp unfolding is_idem_arr_def smc_op_simps by auto



subsection‹Terminal object and initial object›


text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›

definition obj_terminal :: "V ⇒ V ⇒ bool"
  where "obj_terminal ℭ t ⟷ 
    t ∈∘ ℭ⦇Obj⦈ ∧ (∀a. a ∈∘ ℭ⦇Obj⦈ ⟶ (∃!f. f : a ↦ℭ t))"

definition obj_initial :: "V ⇒ V ⇒ bool"
  where "obj_initial ℭ ≡ obj_terminal (op_smc ℭ)"


text‹Rules.›

mk_ide rf obj_terminal_def
  |intro obj_terminalI|
  |dest obj_terminalD[dest]|
  |elim obj_terminalE[elim]|

lemma obj_initialI:
  assumes "a ∈∘ ℭ⦇Obj⦈" and "⋀b. b ∈∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦ℭ b" 
  shows "obj_initial ℭ a"
  unfolding obj_initial_def
  by (simp add: obj_terminalI[of _ ‹op_smc ℭ›, unfolded smc_op_simps, OF assms])

lemma obj_initialD[dest]:
  assumes "obj_initial ℭ a" 
  shows "a ∈∘ ℭ⦇Obj⦈" and "⋀b. b ∈∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦ℭ b"   
  by 
    (
      simp_all add: 
        obj_terminalD[OF assms[unfolded obj_initial_def], unfolded smc_op_simps]
    )

lemma obj_initialE[elim]:
  assumes "obj_initial ℭ a" 
  obtains "a ∈∘ ℭ⦇Obj⦈" and "⋀b. b ∈∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦ℭ b"   
  using assms by (auto simp: obj_initialD)


text‹Elementary properties.›

lemma op_smc_obj_initial[smc_op_simps]: 
  "obj_initial (op_smc ℭ) = obj_terminal ℭ"
  unfolding obj_initial_def obj_terminal_def smc_op_simps ..

lemma op_smc_obj_terminal[smc_op_simps]: 
  "obj_terminal (op_smc ℭ) = obj_initial ℭ"
  unfolding obj_initial_def obj_terminal_def smc_op_simps ..



subsection‹Null object›


text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›

definition obj_null :: "V ⇒ V ⇒ bool"
  where "obj_null ℭ a ⟷ obj_initial ℭ a ∧ obj_terminal ℭ a"


text‹Rules.›

mk_ide rf obj_null_def
  |intro obj_nullI|
  |dest obj_nullD[dest]|
  |elim obj_nullE[elim]|


text‹Elementary properties.›

lemma op_smc_obj_null[smc_op_simps]: "obj_null (op_smc ℭ) a = obj_null ℭ a"
  unfolding obj_null_def smc_op_simps by auto



subsection‹Zero arrow›

definition is_zero_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_zero_arr ℭ a b h ⟷
    (∃z g f. obj_null ℭ z ∧ h = g ∘Aℭ f ∧ f : a ↦ℭ z ∧ g : z ↦ℭ b)"

syntax "_is_zero_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹_ : _ ↦0ı _› [51, 51, 51] 51)
translations "h : a ↦0ℭ b" ⇌ "CONST is_zero_arr ℭ a b h"


text‹Rules.›

lemma is_zero_arrI:
  assumes "obj_null ℭ z" 
    and "h = g ∘Aℭ f" 
    and "f : a ↦ℭ z" 
    and "g : z ↦ℭ b"
  shows "h : a ↦0ℭ b"
  using assms unfolding is_zero_arr_def by auto

lemma is_zero_arrD[dest]:
  assumes "h : a ↦0ℭ b"
  shows "∃z g f. obj_null ℭ z ∧ h = g ∘Aℭ f ∧ f : a ↦ℭ z ∧ g : z ↦ℭ b"
  using assms unfolding is_zero_arr_def by simp

lemma is_zero_arrE[elim]:
  assumes "h : a ↦0ℭ b"
  obtains z g f 
    where "obj_null ℭ z"
      and "h = g ∘Aℭ f" 
      and "f : a ↦ℭ z" 
      and "g : z ↦ℭ b"
  using assms by auto


text‹Elementary properties.›

lemma (in semicategory) op_smc_is_zero_arr[smc_op_simps]: 
  "f : b ↦0op_smc ℭ a ⟷ f : a ↦0ℭ b"
  using op_smc_Comp unfolding is_zero_arr_def smc_op_simps by metis

lemma (in semicategory) smc_is_zero_arr_Comp_right:
  assumes "h : b ↦0ℭ c" and "h' : a ↦ℭ b"
  shows "h ∘Aℭ h' : a ↦0ℭ c"
proof-
  from assms(1) obtain z g f  
    where "obj_null ℭ z" 
      and "h = g ∘Aℭ f" 
      and "f : b ↦ℭ z" 
      and "g : z ↦ℭ c"
    by auto 
  with assms show ?thesis 
    by (auto simp: smc_cs_simps intro: is_zero_arrI smc_cs_intros) 
qed

lemmas [smc_arrow_cs_intros] = semicategory.smc_is_zero_arr_Comp_right

lemma (in semicategory) smc_is_zero_arr_Comp_left:
  assumes "h' : b ↦ℭ c" and "h : a ↦0ℭ b" 
  shows "h' ∘Aℭ h : a ↦0ℭ c"
proof-
  from assms(2) obtain z g f 
    where "obj_null ℭ z" 
      and "h = g ∘Aℭ f" 
      and "f : a ↦ℭ z" 
      and "g : z ↦ℭ b"
    by auto
  with assms(1) show ?thesis
    by (intro is_zero_arrI[of _ _ _ ‹h' ∘Aℭ g›]) 
      (auto simp: smc_Comp_assoc intro: is_zero_arrI smc_cs_intros)
qed

lemmas [smc_arrow_cs_intros] = semicategory.smc_is_zero_arr_Comp_left

text‹\newpage›

end

Theory CZH_SMC_Small_Semicategory

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for semicategories›
theory CZH_SMC_Small_Semicategory
  imports 
    CZH_DG_Small_Digraph
    CZH_SMC_Semicategory
begin



subsection‹Background›


text‹
An explanation of the methodology chosen for the exposition of all
matters related to the size of the semicategories and associated entities
is given in the previous chapter.
›

named_theorems smc_small_cs_simps
named_theorems smc_small_cs_intros



subsection‹Tiny semicategory›


subsubsection‹Definition and elementary properties›

locale tiny_semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
  assumes tiny_smc_length[smc_cs_simps]: "vcard ℭ = 5ℕ"
    and tiny_smc_tiny_digraph[slicing_intros]: "tiny_digraph α (smc_dg ℭ)"
    and tiny_smc_Comp_vdomain: "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and tiny_smc_Comp_is_arr[smc_cs_intros]: 
      "⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and tiny_smc_assoc[smc_cs_simps]:
      "⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"

lemmas [smc_cs_simps] = 
  tiny_semicategory.tiny_smc_length
  tiny_semicategory.tiny_smc_assoc

lemmas [slicing_intros] = 
  tiny_semicategory.tiny_smc_Comp_is_arr


text‹Rules.›

lemma (in tiny_semicategory) tiny_semicategory_axioms'[smc_small_cs_intros]:
  assumes "α' = α"
  shows "tiny_semicategory α' ℭ"
  unfolding assms by (rule tiny_semicategory_axioms)

mk_ide rf tiny_semicategory_def[unfolded tiny_semicategory_axioms_def]
  |intro tiny_semicategoryI|
  |dest tiny_semicategoryD[dest]|
  |elim tiny_semicategoryE[elim]|

lemma tiny_semicategoryI': 
  assumes "semicategory α ℭ" and "ℭ⦇Obj⦈ ∈∘ Vset α" and "ℭ⦇Arr⦈ ∈∘ Vset α"
  shows "tiny_semicategory α ℭ"
proof-
  interpret semicategory α ℭ by (rule assms(1))
  show ?thesis
  proof(intro tiny_semicategoryI)
    show "vfsequence ℭ" by (simp add: vfsequence_axioms)
    from assms show "tiny_digraph α (smc_dg ℭ)"
      by (intro tiny_digraphI') (auto simp: slicing_simps)
  qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed

lemma tiny_semicategoryI'':
  assumes "𝒵 α"
    and "vfsequence ℭ"
    and "vsv (ℭ⦇Comp⦈)"
    and "vcard ℭ = 5ℕ"
    and "vsv (ℭ⦇Dom⦈)"
    and "vsv (ℭ⦇Cod⦈)"
    and "𝒟∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Dom⦈) ⊆∘ ℭ⦇Obj⦈"
    and "𝒟∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
    and "ℛ∘ (ℭ⦇Cod⦈) ⊆∘ ℭ⦇Obj⦈"
    and "⋀gf. gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and "⋀b c g a f. ⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and "⋀c d h b g a f. ⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"
    and "ℭ⦇Obj⦈ ∈∘ Vset α" 
    and "ℭ⦇Arr⦈ ∈∘ Vset α"
  shows "tiny_semicategory α ℭ"
  by (intro tiny_semicategoryI tiny_digraphI, unfold slicing_simps) 
    (simp_all add: smc_dg_def nat_omega_simps assms)


text‹Slicing.›

context tiny_semicategory
begin

interpretation dg: tiny_digraph α ‹smc_dg ℭ› by (rule tiny_smc_tiny_digraph)

lemmas_with [unfolded slicing_simps]:
  tiny_smc_Obj_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Obj_in_Vset
  and tiny_smc_Arr_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Arr_in_Vset
  and tiny_smc_Dom_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Dom_in_Vset
  and tiny_smc_Cod_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Cod_in_Vset

end


text‹Elementary properties.›

sublocale tiny_semicategory ⊆ semicategory
  by (rule semicategoryI)
    (
      auto 
        simp: 
          vfsequence_axioms
          tiny_digraph.tiny_dg_digraph 
          tiny_smc_tiny_digraph
          tiny_smc_Comp_vdomain         
        intro: smc_cs_intros smc_cs_simps 
    )

lemmas (in tiny_semicategory) tiny_dg_semicategory = semicategory_axioms

lemmas [smc_small_cs_intros] = tiny_semicategory.tiny_dg_semicategory


text‹Size.›

lemma (in tiny_semicategory) tiny_smc_Comp_in_Vset: "ℭ⦇Comp⦈ ∈∘ Vset α"
proof-
  have "ℭ⦇Arr⦈ ∈∘ Vset α" by (simp add: tiny_smc_Arr_in_Vset)
  with Axiom_of_Infinity have "ℭ⦇Arr⦈ ^× 2ℕ ∈∘ Vset α" 
    by (intro Limit_vcpower_in_VsetI) auto
  with Comp.pnop_vdomain have D: "𝒟∘ (ℭ⦇Comp⦈) ∈∘ Vset α" by auto
  moreover from tiny_smc_Arr_in_Vset smc_Comp_vrange have 
    "ℛ∘ (ℭ⦇Comp⦈) ∈∘ Vset α"
    by auto
  ultimately show ?thesis by (simp add: Comp.vbrelation_Limit_in_VsetI)
qed

lemma (in tiny_semicategory) tiny_smc_in_Vset: "ℭ ∈∘ Vset α"
proof-
  note [smc_cs_intros] = 
    tiny_smc_Obj_in_Vset 
    tiny_smc_Arr_in_Vset
    tiny_smc_Dom_in_Vset
    tiny_smc_Cod_in_Vset
    tiny_smc_Comp_in_Vset
  show ?thesis by (subst smc_def) (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed

lemma small_tiny_semicategories[simp]: "small {ℭ. tiny_semicategory α ℭ}"
proof(rule down)
  show "{ℭ. tiny_semicategory α ℭ} ⊆ elts (set {ℭ. semicategory α ℭ})" 
    by (auto intro: smc_small_cs_intros)
qed

lemma tiny_semicategories_vsubset_Vset: 
  "set {ℭ. tiny_semicategory α ℭ} ⊆∘ Vset α" 
  by (rule vsubsetI) (simp add: tiny_semicategory.tiny_smc_in_Vset)

lemma (in semicategory) smc_tiny_semicategory_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_semicategory β ℭ"
proof(intro tiny_semicategoryI)
  show "tiny_digraph β (smc_dg ℭ)"
    by (rule digraph.dg_tiny_digraph_if_ge_Limit, rule smc_digraph; intro assms)
qed 
  (
    auto simp: 
      assms(1)
      smc_cs_simps 
      smc_cs_intros 
      smc_digraph digraph.dg_tiny_digraph_if_ge_Limit 
      smc_Comp_vdomain vfsequence_axioms
  )


subsubsection‹Opposite tiny semicategory›

lemma (in tiny_semicategory) tiny_semicategory_op: 
  "tiny_semicategory α (op_smc ℭ)"
  by (intro tiny_semicategoryI', unfold smc_op_simps)
    (auto simp: smc_op_intros smc_small_cs_intros)

lemmas tiny_semicategory_op[smc_op_intros] = 
  tiny_semicategory.tiny_semicategory_op



subsection‹Finite semicategory›


subsubsection‹Definition and elementary properties›


text‹
A finite semicategory is a generalization of the concept of a finite category,
as presented in nLab 
\cite{noauthor_nlab_nodate}
\footnote{\url{https://ncatlab.org/nlab/show/finite+category}}.
›

locale finite_semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
  assumes fin_smc_length[smc_cs_simps]: "vcard ℭ = 5ℕ"
    and fin_smc_finite_digraph[slicing_intros]: "finite_digraph α (smc_dg ℭ)"
    and fin_smc_Comp_vdomain: "gf ∈∘ 𝒟∘ (ℭ⦇Comp⦈) ⟷
      (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦ℭ c ∧ f : a ↦ℭ b)"
    and fin_smc_Comp_is_arr[smc_cs_intros]: 
      "⟦ g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹ g ∘Aℭ f : a ↦ℭ c"
    and fin_smc_assoc[smc_cs_simps]:
      "⟦ h : c ↦ℭ d; g : b ↦ℭ c; f : a ↦ℭ b ⟧ ⟹
        (h ∘Aℭ g) ∘Aℭ f = h ∘Aℭ (g ∘Aℭ f)"

lemmas [smc_cs_simps] = 
  finite_semicategory.fin_smc_length
  finite_semicategory.fin_smc_assoc

lemmas [slicing_intros] = 
  finite_semicategory.fin_smc_Comp_is_arr


text‹Rules.›

lemma (in finite_semicategory) finite_semicategory_axioms'[smc_small_cs_intros]:
  assumes "α' = α"
  shows "finite_semicategory α' ℭ"
  unfolding assms by (rule finite_semicategory_axioms)

mk_ide rf finite_semicategory_def[unfolded finite_semicategory_axioms_def]
  |intro finite_semicategoryI|
  |dest finite_semicategoryD[dest]|
  |elim finite_semicategoryE[elim]|

lemma finite_semicategoryI': 
  assumes "semicategory α ℭ" and "vfinite (ℭ⦇Obj⦈)" and "vfinite (ℭ⦇Arr⦈)"
  shows "finite_semicategory α ℭ"
proof-
  interpret semicategory α ℭ by (rule assms(1))
  show ?thesis
  proof(intro finite_semicategoryI)
    show "vfsequence ℭ" by (simp add: vfsequence_axioms)
    from assms show "finite_digraph α (smc_dg ℭ)"
      by (intro finite_digraphI) (auto simp: slicing_simps)
  qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed

lemma finite_semicategoryI'': 
  assumes "tiny_semicategory α ℭ" and "vfinite (ℭ⦇Obj⦈)" and "vfinite (ℭ⦇Arr⦈)"
  shows "finite_semicategory α ℭ"
  using assms by (intro finite_semicategoryI') 
    (auto intro: smc_cs_intros smc_small_cs_intros)


text‹Slicing.›

context finite_semicategory
begin

interpretation dg: finite_digraph α ‹smc_dg ℭ› by (rule fin_smc_finite_digraph)

lemmas_with [unfolded slicing_simps]:
  fin_smc_Obj_vfinite[smc_small_cs_intros] = dg.fin_dg_Obj_vfinite
  and fin_smc_Arr_vfinite[smc_small_cs_intros] = dg.fin_dg_Arr_vfinite

end


text‹Elementary properties.›

sublocale finite_semicategory ⊆ tiny_semicategory
  by (rule tiny_semicategoryI)
    (
      auto simp: 
        vfsequence_axioms
        fin_smc_Comp_vdomain         
        fin_smc_finite_digraph 
        finite_digraph.fin_dg_tiny_digraph
        intro: smc_cs_intros smc_cs_simps 
    )

lemmas (in finite_semicategory) fin_smc_tiny_semicategory = 
  tiny_semicategory_axioms

lemmas [smc_small_cs_intros] = finite_semicategory.fin_smc_tiny_semicategory

lemma (in finite_semicategory) fin_smc_in_Vset: "ℭ ∈∘ Vset α"
  by (rule tiny_smc_in_Vset)


text‹Size.›

lemma small_finite_semicategories[simp]: "small {ℭ. finite_semicategory α ℭ}"
proof(rule down)
  show "{ℭ. finite_semicategory α ℭ} ⊆ elts (set {ℭ. semicategory α ℭ})" 
    by (auto intro: smc_small_cs_intros)
qed

lemma finite_semicategories_vsubset_Vset: 
  "set {ℭ. finite_semicategory α ℭ} ⊆∘ Vset α" 
  by (rule vsubsetI) (simp add: finite_semicategory.fin_smc_in_Vset)
 

subsubsection‹Opposite finite semicategory›

lemma (in finite_semicategory) finite_semicategory_op: 
  "finite_semicategory α (op_smc ℭ)"
  by (intro finite_semicategoryI', unfold smc_op_simps)
    (auto simp: smc_op_intros smc_small_cs_intros)

lemmas finite_semicategory_op[smc_op_intros] = 
  finite_semicategory.finite_semicategory_op

text‹\newpage›

end

Theory CZH_SMC_Semifunctor

(* Copyright 2021 (C) Mihails Milehins *)

section‹Semifunctor›
theory CZH_SMC_Semifunctor
  imports 
    CZH_DG_DGHM
    CZH_SMC_Semicategory
begin



subsection‹Background›

named_theorems smcf_cs_simps
named_theorems smcf_cs_intros

named_theorems smc_cn_cs_simps
named_theorems smc_cn_cs_intros

lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros


subsubsection‹Slicing›

definition smcf_dghm :: "V ⇒ V"
  where "smcf_dghm ℭ = 
    [ℭ⦇ObjMap⦈, ℭ⦇ArrMap⦈, smc_dg (ℭ⦇HomDom⦈), smc_dg (ℭ⦇HomCod⦈)]∘"


text‹Components.›

lemma smcf_dghm_components:
  shows [slicing_simps]: "smcf_dghm 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
    and [slicing_simps]: "smcf_dghm 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    and [slicing_commute]: "smcf_dghm 𝔉⦇HomDom⦈ = smc_dg (𝔉⦇HomDom⦈)"
    and [slicing_commute]: "smcf_dghm 𝔉⦇HomCod⦈ = smc_dg (𝔉⦇HomCod⦈)"
  unfolding smcf_dghm_def dghm_field_simps by (auto simp: nat_omega_simps)



subsection‹Definition and elementary properties›


text‹
See Chapter I-3 in \cite{mac_lane_categories_2010} and the description
of the concept of a digraph homomorphism in the previous chapter.
›

locale is_semifunctor = 
  𝒵 α +
  vfsequence 𝔉 + 
  HomDom: semicategory α 𝔄 + 
  HomCod: semicategory α 𝔅 
  for α 𝔄 𝔅 𝔉 +
  assumes smcf_length[smc_cs_simps]: "vcard 𝔉 = 4ℕ" 
    and smcf_is_dghm[slicing_intros]: 
      "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DGα smc_dg 𝔅" 
    and smcf_HomDom[smc_cs_simps]: "𝔉⦇HomDom⦈ = 𝔄"
    and smcf_HomCod[smc_cs_simps]: "𝔉⦇HomCod⦈ = 𝔅"
    and smcf_ArrMap_Comp[smc_cs_simps]: "⟦ g : b ↦𝔄 c; f : a ↦𝔄 b ⟧ ⟹
      𝔉⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈"

syntax "_is_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMCı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMCα 𝔅" ⇌ "CONST is_semifunctor α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_semifunctor :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_semifunctor α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_smc 𝔄 ↦↦SMCα 𝔅"

syntax "_is_cn_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ SMC↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 SMC↦↦α 𝔅" ⇀ "CONST is_cn_semifunctor α 𝔄 𝔅 𝔉"

abbreviation all_smcfs :: "V ⇒ V"
  where "all_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅}"

abbreviation smcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦SMCα 𝔅}"

lemmas [smc_cs_simps] =
  is_semifunctor.smcf_HomDom
  is_semifunctor.smcf_HomCod
  is_semifunctor.smcf_ArrMap_Comp

lemma smcf_is_dghm'[slicing_intros]:
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔄' = smc_dg 𝔄"
    and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DGα 𝔅'"
  using assms(1) unfolding assms(2,3) by (rule is_semifunctor.smcf_is_dghm)

lemma cn_dghm_comp_is_dghm: 
  assumes "𝔉 : op_smc 𝔄 ↦↦SMCα 𝔅"
  shows "smcf_dghm 𝔉 : op_dg (smc_dg 𝔄) ↦↦DGα smc_dg 𝔅"
  using assms 
  unfolding slicing_simps slicing_commute
  by (cs_concl cs_intro: slicing_intros)

lemma cn_dghm_comp_is_dghm'[slicing_intros]: 
  assumes "𝔉 : op_smc 𝔄 ↦↦SMCα 𝔅"
    and "𝔄' = op_dg (smc_dg 𝔄)"
    and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DGα 𝔅'"
  using assms(1) unfolding assms(2,3) by (rule cn_dghm_comp_is_dghm)


text‹Rules.›

lemma (in is_semifunctor) is_semifunctor_axioms'[smc_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦SMCα' 𝔅'"
  unfolding assms by (rule is_semifunctor_axioms)

mk_ide rf is_semifunctor_def[unfolded is_semifunctor_axioms_def]
  |intro is_semifunctorI|
  |dest is_semifunctorD[dest]|
  |elim is_semifunctorE[elim]|

lemmas [smc_cs_intros] =
  is_semifunctorD(3,4)

lemma is_semifunctorI':
  assumes "𝒵 α" 
    and "vfsequence 𝔉" 
    and "semicategory α 𝔄"
    and "semicategory α 𝔅" 
    and "vcard 𝔉 = 4ℕ"
    and "𝔉⦇HomDom⦈ = 𝔄"
    and "𝔉⦇HomCod⦈ = 𝔅"
    and "vsv (𝔉⦇ObjMap⦈)"
    and "vsv (𝔉⦇ArrMap⦈)"
    and "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 𝔅⦇Obj⦈"
    and "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"
    and "⋀b c g a f. ⟦ g : b ↦𝔄 c; f : a ↦𝔄 b ⟧ ⟹
      𝔉⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  by (intro is_semifunctorI is_dghmI, unfold smcf_dghm_components slicing_simps)
    (simp_all add: assms smcf_dghm_def nat_omega_simps semicategory.smc_digraph)

lemma is_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒵 α" 
    and "vfsequence 𝔉" 
    and "semicategory α 𝔄"
    and "semicategory α 𝔅" 
    and "vcard 𝔉 = 4ℕ"
    and "𝔉⦇HomDom⦈ = 𝔄"
    and "𝔉⦇HomCod⦈ = 𝔅"
    and "vsv (𝔉⦇ObjMap⦈)"
    and "vsv (𝔉⦇ArrMap⦈)"
    and "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 𝔅⦇Obj⦈"
    and "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"
    and "⋀b c g a f. ⟦ g : b ↦𝔄 c; f : a ↦𝔄 b ⟧ ⟹
      𝔉⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈"
  by
    (
      simp_all add: 
        is_semifunctorD(2-9)[OF assms] 
        is_dghmD[OF is_semifunctorD(6)[OF assms], unfolded slicing_simps]
    )

lemma is_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  obtains "𝒵 α" 
    and "vfsequence 𝔉" 
    and "semicategory α 𝔄"
    and "semicategory α 𝔅" 
    and "vcard 𝔉 = 4ℕ"
    and "𝔉⦇HomDom⦈ = 𝔄"
    and "𝔉⦇HomCod⦈ = 𝔅"
    and "vsv (𝔉⦇ObjMap⦈)"
    and "vsv (𝔉⦇ArrMap⦈)"
    and "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 𝔅⦇Obj⦈"
    and "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔉⦇ObjMap⦈⦇b⦈"
    and "⋀b c g a f. ⟦ g : b ↦𝔄 c; f : a ↦𝔄 b ⟧ ⟹
      𝔉⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈"
  using assms by (simp add: is_semifunctorD')


text‹Slicing.›

context is_semifunctor
begin

interpretation dghm: is_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule smcf_is_dghm)

sublocale ObjMap: vsv ‹𝔉⦇ObjMap⦈›
  by (rule dghm.ObjMap.vsv_axioms[unfolded slicing_simps])
sublocale ArrMap: vsv ‹𝔉⦇ArrMap⦈›
  by (rule dghm.ArrMap.vsv_axioms[unfolded slicing_simps])

lemmas_with [unfolded slicing_simps]:
  smcf_ObjMap_vsv = dghm.dghm_ObjMap_vsv
  and smcf_ArrMap_vsv = dghm.dghm_ArrMap_vsv
  and smcf_ObjMap_vdomain[smc_cs_simps] = dghm.dghm_ObjMap_vdomain
  and smcf_ObjMap_vrange = dghm.dghm_ObjMap_vrange
  and smcf_ArrMap_vdomain[smc_cs_simps] = dghm.dghm_ArrMap_vdomain
  and smcf_ArrMap_is_arr = dghm.dghm_ArrMap_is_arr
  and smcf_ArrMap_is_arr''[smc_cs_intros] = dghm.dghm_ArrMap_is_arr''
  and smcf_ArrMap_is_arr'[smc_cs_intros] = dghm.dghm_ArrMap_is_arr'
  and smcf_ObjMap_app_in_HomCod_Obj[smc_cs_intros] = 
    dghm.dghm_ObjMap_app_in_HomCod_Obj
  and smcf_ArrMap_vrange = dghm.dghm_ArrMap_vrange
  and smcf_ArrMap_app_in_HomCod_Arr[smc_cs_intros] = 
    dghm.dghm_ArrMap_app_in_HomCod_Arr
  and smcf_ObjMap_vsubset_Vset = dghm.dghm_ObjMap_vsubset_Vset
  and smcf_ArrMap_vsubset_Vset = dghm.dghm_ArrMap_vsubset_Vset
  and smcf_ObjMap_in_Vset = dghm.dghm_ObjMap_in_Vset
  and smcf_ArrMap_in_Vset = dghm.dghm_ArrMap_in_Vset
  and smcf_is_dghm_if_ge_Limit = dghm.dghm_is_dghm_if_ge_Limit
  and smcf_is_arr_HomCod = dghm.dghm_is_arr_HomCod
  and smcf_vimage_dghm_ArrMap_vsubset_Hom = 
    dghm.dghm_vimage_dghm_ArrMap_vsubset_Hom

end

lemmas [smc_cs_simps] =
  is_semifunctor.smcf_ObjMap_vdomain
  is_semifunctor.smcf_ArrMap_vdomain

lemmas [smc_cs_intros] =
  is_semifunctor.smcf_ObjMap_app_in_HomCod_Obj
  is_semifunctor.smcf_ArrMap_app_in_HomCod_Arr
  is_semifunctor.smcf_ArrMap_is_arr'


text‹Elementary properties.›

lemma cn_smcf_ArrMap_Comp[smc_cs_simps]:
  assumes "semicategory α 𝔄"
    and "𝔉 : op_smc 𝔄 ↦↦SMCα 𝔅"
    and "g : c ↦𝔄 b"
    and "f : b ↦𝔄 a"
  shows "𝔉⦇ArrMap⦈⦇f ∘A𝔄 g⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈"
proof-
  from assms(3,4) have gf:
    "𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔉⦇ArrMap⦈⦇g ∘Aop_smc 𝔄 f⦈"
    by
      (
        force
          intro: is_semifunctor.smcf_ArrMap_Comp[OF assms(2), symmetric]
          simp: slicing_simps smc_op_simps
      )
  from assms show ?thesis
    unfolding gf by (cs_concl cs_simp: smc_op_simps) 
qed

lemma smcf_eqI:
  assumes "𝔊 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔉 : ℭ ↦↦SMCα 𝔇"
    and "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
    and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    and "𝔄 = ℭ"
    and "𝔅 = 𝔇"
  shows "𝔊 = 𝔉"
proof-
  interpret L: is_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(1))
  interpret R: is_semifunctor α ℭ 𝔇 𝔉 by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ 𝔊 = 4ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
    show "𝒟∘ 𝔊 = 𝒟∘ 𝔉" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
    from assms(5,6) have sup: "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈" 
      by (simp_all add: smc_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔊 ⟹ 𝔊⦇a⦈ = 𝔉⦇a⦈" for a 
      by (unfold dom, elim_in_numeral, insert assms(3,4) sup)
        (auto simp: dghm_field_simps)
  qed auto
qed

lemma smcf_dghm_eqI:
  assumes "𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : ℭ ↦↦SMCα 𝔇"
    and "𝔄 = ℭ"
    and "𝔅 = 𝔇"
    and "smcf_dghm 𝔊 = smcf_dghm 𝔉"
  shows "𝔊 = 𝔉"
proof(rule smcf_eqI)
  from assms(5) have 
    "smcf_dghm 𝔊⦇ObjMap⦈ = smcf_dghm 𝔉⦇ObjMap⦈"
    "smcf_dghm 𝔊⦇ArrMap⦈ = smcf_dghm 𝔉⦇ArrMap⦈"
    by simp_all
  then show "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    unfolding slicing_simps by simp_all
qed (auto intro: assms(1,2) simp: assms)

lemma (in is_semifunctor) smcf_def: 
  "𝔉 = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ 𝔉 = 4ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
  have dom_rhs: "𝒟∘ [𝔉⦇Obj⦈, 𝔉⦇Arr⦈, 𝔉⦇Dom⦈, 𝔉⦇Cod⦈]∘ = 4ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ 𝔉 = 𝒟∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘"
    unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
  show "a ∈∘ 𝒟∘ 𝔉 ⟹ 𝔉⦇a⦈ = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]∘⦇a⦈" 
    for a
    by (unfold dom_lhs, elim_in_numeral, unfold dghm_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)

lemma (in is_semifunctor) smcf_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [smc_cs_intros] = 
    smcf_ObjMap_in_Vset 
    smcf_ArrMap_in_Vset 
    HomDom.smc_in_Vset 
    HomCod.smc_in_Vset
  from assms(2) show ?thesis
    by (subst smcf_def) 
      (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed

lemma (in is_semifunctor) smcf_is_semifunctor_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 : 𝔄 ↦↦SMCβ 𝔅"
  by (rule is_semifunctorI)
    (
      simp_all add: 
        assms 
        vfsequence_axioms
        smcf_is_dghm_if_ge_Limit
        HomDom.smc_semicategory_if_ge_Limit
        HomCod.smc_semicategory_if_ge_Limit
        smc_cs_simps
    )

lemma small_all_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅}"
proof(cases ‹𝒵 α›)
  case True
  from is_semifunctor.smcf_in_Vset show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›]) 
      (auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅} = {}" by auto
  then show ?thesis by simp
qed

lemma (in is_semifunctor) smcf_in_Vset_7: "𝔉 ∈∘ Vset (α + 7ℕ)"
proof-
  note [folded VPow_iff, folded Vset_succ[OF Ord_α], smc_cs_intros] =
    smcf_ObjMap_vsubset_Vset 
    smcf_ArrMap_vsubset_Vset
  from HomDom.smc_semicategory_in_Vset_4 have [smc_cs_intros]:
    "𝔄 ∈∘ Vset (succ (succ (succ (succ α))))"
    by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
  from HomCod.smc_semicategory_in_Vset_4 have [smc_cs_intros]:
    "𝔅 ∈∘ Vset (succ (succ (succ (succ α))))"
    by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
  show ?thesis
    by (subst smcf_def, succ_of_numeral)
      (
        cs_concl 
          cs_simp: plus_V_succ_right V_cs_simps smc_cs_simps 
          cs_intro: smc_cs_intros V_cs_intros
      )
qed

lemma (in 𝒵) all_smcfs_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "all_smcfs α ∈∘ Vset β"
proof(rule vsubset_in_VsetI)
  interpret β: 𝒵 β by (rule assms(1))
  show "all_smcfs α ⊆∘ Vset (α + 7ℕ)"
  proof(intro vsubsetI)
    fix 𝔉 assume "𝔉 ∈∘ all_smcfs α"
    then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦SMCα 𝔅" by clarsimp
    then interpret is_semifunctor α 𝔄 𝔅 𝔉 .
    show "𝔉 ∈∘ Vset (α + 7ℕ)" by (rule smcf_in_Vset_7)
  qed
  from assms(2) show "Vset (α + 7ℕ) ∈∘ Vset β"
    by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed

lemma small_smcfs[simp]: "small {𝔉. 𝔉 : 𝔄 ↦↦SMCα 𝔅}"
  by (rule down[of _ ‹set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅}›]) auto



subsection‹Opposite semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›

definition op_smcf :: "V ⇒ V"
  where "op_smcf 𝔉 =
    [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, op_smc (𝔉⦇HomDom⦈), op_smc (𝔉⦇HomCod⦈)]∘"


text‹Components.›

lemma op_smcf_components[smc_op_simps]:
  shows "op_smcf 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
    and "op_smcf 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
    and "op_smcf 𝔉⦇HomDom⦈ = op_smc (𝔉⦇HomDom⦈)"
    and "op_smcf 𝔉⦇HomCod⦈ = op_smc (𝔉⦇HomCod⦈)"
  unfolding op_smcf_def dghm_field_simps by (auto simp: nat_omega_simps)


text‹Slicing.›

lemma op_dghm_smcf_dghm[slicing_commute]: 
  "op_dghm (smcf_dghm 𝔉) = smcf_dghm (op_smcf 𝔉)"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ (op_dghm (smcf_dghm 𝔉)) = 4ℕ"
    unfolding op_dghm_def by (auto simp: nat_omega_simps)
  have dom_rhs: "𝒟∘ (smcf_dghm (op_smcf 𝔉)) = 4ℕ"
    unfolding smcf_dghm_def by (auto simp: nat_omega_simps)
  show "𝒟∘ (op_dghm (smcf_dghm 𝔉)) = 𝒟∘ (smcf_dghm (op_smcf 𝔉))"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (op_dghm (smcf_dghm 𝔉)) ⟹
    op_dghm (smcf_dghm 𝔉)⦇a⦈ = smcf_dghm (op_smcf 𝔉)⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral,
        unfold smcf_dghm_def op_smcf_def op_dghm_def dghm_field_simps
      ) 
      (auto simp: nat_omega_simps slicing_simps slicing_commute)
qed (auto simp: smcf_dghm_def op_dghm_def)


subsubsection‹Further properties›

lemma (in is_semifunctor) is_semifunctor_op:
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMCα op_smc 𝔅"
proof(intro is_semifunctorI)
  show "vfsequence (op_smcf 𝔉)" unfolding op_smcf_def by simp
  show "vcard (op_smcf 𝔉) = 4ℕ" 
    unfolding op_smcf_def by (auto simp: nat_omega_simps)
  fix g b c f a assume "g : b ↦op_smc 𝔄 c" "f : a ↦op_smc 𝔄 b"
  then have "g : c ↦𝔄 b" and "f : b ↦𝔄 a"  
    unfolding smc_op_simps by simp_all
  with is_semifunctor_axioms show 
    "op_smcf 𝔉⦇ArrMap⦈⦇g ∘Aop_smc 𝔄 f⦈ =
      op_smcf 𝔉⦇ArrMap⦈⦇g⦈ ∘Aop_smc 𝔅 op_smcf 𝔉⦇ArrMap⦈⦇f⦈"
    by 
      (
        cs_concl 
          cs_simp: smc_op_simps smc_cs_simps 
          cs_intro: smc_op_intros smc_cs_intros
      )
qed 
  (
    auto simp: 
      smc_cs_simps
      smc_op_simps
      slicing_simps
      slicing_commute[symmetric]
      is_dghm.is_dghm_op 
      smcf_is_dghm
      HomCod.semicategory_op 
      HomDom.semicategory_op
  )

lemma (in is_semifunctor) is_semifunctor_op':  
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMCα' 𝔅'"
  unfolding assms by (rule is_semifunctor_op)

lemmas is_semifunctor_op'[smc_op_intros] = is_semifunctor.is_semifunctor_op'

lemma (in is_semifunctor) smcf_op_smcf_op_smcf[smc_op_simps]: 
  "op_smcf (op_smcf 𝔉) = 𝔉" 
proof(rule smcf_eqI, unfold smc_op_simps)
  show "op_smcf (op_smcf 𝔉) : 𝔄 ↦↦SMCα 𝔅"
    by 
      (
        metis 
          HomCod.smc_op_smc_op_smc 
          HomDom.smc_op_smc_op_smc 
          is_semifunctor.is_semifunctor_op 
          is_semifunctor_op
      )
qed (simp_all add: is_semifunctor_axioms)

lemmas smcf_op_smcf_op_smcf[smc_op_simps] = is_semifunctor.smcf_op_smcf_op_smcf

lemma eq_op_smcf_iff[smc_op_simps]: 
  assumes "𝔊 : 𝔄 ↦↦SMCα 𝔅" and "𝔉 : ℭ ↦↦SMCα 𝔇"
  shows "op_smcf 𝔊 = op_smcf 𝔉 ⟷ 𝔊 = 𝔉"
proof
  interpret L: is_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(1))
  interpret R: is_semifunctor α ℭ 𝔇 𝔉 by (rule assms(2))
  assume prems: "op_smcf 𝔊 = op_smcf 𝔉"
  show "𝔊 = 𝔉"
  proof(rule smcf_eqI[OF assms])
    from prems R.smcf_op_smcf_op_smcf L.smcf_op_smcf_op_smcf show 
      "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
      by metis+
    from prems R.smcf_op_smcf_op_smcf L.smcf_op_smcf_op_smcf have 
      "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
      by auto
    then show "𝔄 = ℭ" "𝔅 = 𝔇" by (simp_all add: smc_cs_simps)
  qed
qed auto



subsection‹Composition of covariant semifunctors›


subsubsection‹Definition and elementary properties›

abbreviation (input) smcf_comp :: "V ⇒ V ⇒ V" (infixl "∘SMCF" 55)
  where "smcf_comp ≡ dghm_comp"


text‹Slicing.›

lemma smcf_dghm_smcf_comp[slicing_commute]: 
  "smcf_dghm 𝔊 ∘DGHM smcf_dghm 𝔉 = smcf_dghm (𝔊 ∘SMCF 𝔉)"
  unfolding dghm_comp_def smcf_dghm_def dghm_field_simps 
  by (simp add: nat_omega_simps)


subsubsection‹Object map›

lemma smcf_comp_ObjMap_vsv[smc_cs_intros]: 
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "vsv ((𝔊 ∘SMCF 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ObjMap_vsv
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ObjMap_vdomain[smc_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔊 ∘SMCF 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ObjMap_vdomain
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔊 ∘SMCF 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ObjMap_vrange
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ObjMap_app[smc_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" 
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and [simp]: "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 ∘SMCF 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ObjMap_app
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute, 
            OF assms(3)
          ]
      )
qed


subsubsection‹Arrow map›

lemma smcf_comp_ArrMap_vsv[smc_cs_intros]: 
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "vsv ((𝔊 ∘SMCF 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis 
    by 
      (
        rule dghm_comp_ArrMap_vsv
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ArrMap_vdomain[smc_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔊 ∘SMCF 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ArrMap_vdomain
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ArrMap_vrange:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔊 ∘SMCF 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ArrMap_vrange
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute
          ]
      )
qed

lemma smcf_comp_ArrMap_app[smc_cs_simps]:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" 
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and [simp]: "f ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 ∘SMCF 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_comp_ArrMap_app
          [
            OF L.smcf_is_dghm R.smcf_is_dghm, 
            unfolded slicing_simps slicing_commute,
            OF assms(3)
          ]
      )
qed


subsubsection‹Further properties›

lemma smcf_comp_is_semifunctor[smc_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ"
proof-
  interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
  proof(rule is_semifunctorI, unfold dghm_comp_components(3,4))
    show "vfsequence (𝔊 ∘SMCF 𝔉)" by (simp add: dghm_comp_def)
    show "vcard (𝔊 ∘SMCF 𝔉) = 4ℕ"  
      unfolding dghm_comp_def by (simp add: nat_omega_simps)
    fix g b c f a assume "g : b ↦𝔄 c" "f : a ↦𝔄 b"
    with assms show "(𝔊 ∘SMCF 𝔉)⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 
      (𝔊 ∘SMCF 𝔉)⦇ArrMap⦈⦇g⦈ ∘Aℭ (𝔊 ∘SMCF 𝔉)⦇ArrMap⦈⦇f⦈"
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  qed 
    (
      auto 
        simp: slicing_commute[symmetric] smc_cs_simps smc_cs_intros 
        intro: dg_cs_intros slicing_intros
    )
qed 

lemma smcf_comp_assoc[smc_cs_simps]:
  assumes "ℌ : ℭ ↦↦SMCα 𝔇" 
    and "𝔊 : 𝔅 ↦↦SMCα ℭ" 
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "(ℌ ∘SMCF 𝔊) ∘SMCF 𝔉 = ℌ ∘SMCF (𝔊 ∘SMCF 𝔉)"
proof(rule smcf_eqI[of α 𝔄 𝔇 _ 𝔄 𝔇])
  interpret ℌ: is_semifunctor α ℭ 𝔇 ℌ by (rule assms(1)) 
  interpret 𝔊: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(2)) 
  interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(3)) 
  from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms ℌ.is_semifunctor_axioms 
  show "ℌ ∘SMCF (𝔊 ∘SMCF 𝔉) : 𝔄 ↦↦SMCα 𝔇" 
    and "ℌ ∘SMCF 𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα 𝔇"  
    by (auto intro: smc_cs_intros)
qed (simp_all add: dghm_comp_components vcomp_assoc)

lemma op_smcf_smcf_comp[smc_op_simps]: 
  "op_smcf (𝔊 ∘SMCF 𝔉) = op_smcf 𝔊 ∘SMCF op_smcf 𝔉"
  unfolding dghm_comp_def op_smcf_def dghm_field_simps 
  by (simp add: nat_omega_simps)



subsection‹Composition of contravariant semifunctors›


subsubsection‹Definition and elementary properties›


text‹See section 1.2 in \cite{bodo_categories_1970}.›

definition smcf_cn_comp :: "V ⇒ V ⇒ V" (infixl ‹SMCF∘› 55)
  where "𝔊 SMCF∘ 𝔉 =
    [
      𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈, 
      𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈, 
      op_smc (𝔉⦇HomDom⦈), 
      𝔊⦇HomCod⦈
    ]∘"


text‹Components.›

lemma smcf_cn_comp_components:
  shows "(𝔊 SMCF∘ 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘∘ 𝔉⦇ObjMap⦈"
    and "(𝔊 SMCF∘ 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘∘ 𝔉⦇ArrMap⦈"
    and [smc_cn_cs_simps]: "(𝔊 SMCF∘ 𝔉)⦇HomDom⦈ = op_smc (𝔉⦇HomDom⦈)"
    and [smc_cn_cs_simps]: "(𝔊 SMCF∘ 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
  unfolding smcf_cn_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_smcf_cn_comp[slicing_commute]: 
  "smcf_dghm 𝔊 DGHM∘ smcf_dghm 𝔉 = smcf_dghm (𝔊 SMCF∘ 𝔉)"
  unfolding dghm_cn_comp_def smcf_cn_comp_def smcf_dghm_def  
  by (simp add: nat_omega_simps slicing_commute dghm_field_simps)


subsubsection‹Object map: two contravariant semifunctors›

lemma smcf_cn_comp_ObjMap_vsv[smc_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "vsv ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ObjMap_vsv
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ObjMap_vdomain[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "𝒟∘ ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ObjMap_vdomain
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "ℛ∘ ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ObjMap_vrange
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ObjMap_app[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 SMCF∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ObjMap_app
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps, 
            OF assms(3)
          ]
      )
qed


subsubsection‹Arrow map: two contravariant semifunctors›

lemma smcf_cn_comp_ArrMap_vsv[smc_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "vsv ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ArrMap_vsv
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ArrMap_vdomain[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "𝒟∘ ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ArrMap_vdomain
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ArrMap_vrange:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "ℛ∘ ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ArrMap_vrange
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_comp_ArrMap_app[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅" and "a ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_comp_ArrMap_app
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps,
            OF assms(3)
          ]
      )
qed


subsubsection‹Object map: contravariant and covariant semifunctors›

lemma smcf_cn_cov_comp_ObjMap_vsv[smc_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "vsv ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈)"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ObjMap_vsv
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ObjMap_vdomain[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ObjMap_vdomain
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ObjMap_vrange:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔊 SMCF∘ 𝔉)⦇ObjMap⦈) ⊆∘ ℭ⦇Obj⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ObjMap_vrange
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ObjMap_app[smc_cn_cs_simps]:
    assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅" and "a ∈∘ 𝔄⦇Obj⦈"
  shows "(𝔊 SMCF∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ObjMap_app
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps,
            OF assms(3)
          ]
      )
qed


subsubsection‹Arrow map: contravariant and covariant semifunctors›

lemma smcf_cn_cov_comp_ArrMap_vsv[smc_cn_cs_intros]: 
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "vsv ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈)"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ArrMap_vsv
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
              R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ArrMap_vdomain[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ArrMap_vdomain
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ArrMap_vrange:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔊 SMCF∘ 𝔉)⦇ArrMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ArrMap_vrange
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps
          ]
      )
qed

lemma smcf_cn_cov_comp_ArrMap_app[smc_cn_cs_simps]:
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅" and "f ∈∘ 𝔄⦇Arr⦈"
  shows "(𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1)) 
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
    by 
      (
        rule dghm_cn_cov_comp_ArrMap_app
          [
            OF 
              L.smcf_is_dghm[unfolded slicing_commute[symmetric]] 
              R.smcf_is_dghm,
            unfolded slicing_commute slicing_simps,
            OF assms(3)
          ]
      )
qed


subsubsection‹Opposite of the contravariant composition of semifunctors›

lemma op_smcf_smcf_cn_comp[smc_op_simps]: 
  "op_smcf (𝔊 SMCF∘ 𝔉) = op_smcf 𝔊 SMCF∘ op_smcf 𝔉"
  unfolding op_smcf_def smcf_cn_comp_def dghm_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹Further properties›

lemma smcf_cn_comp_is_semifunctor[smc_cn_cs_intros]:
  ―‹See section 1.2 in \cite{bodo_categories_1970}.›
  assumes "semicategory α 𝔄" and "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "𝔊 SMCF∘ 𝔉 : 𝔄 ↦↦SMCα ℭ"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 
    rewrites "f : b ↦op_smc ℭ' a = f : a ↦ℭ' b" for ℭ' f b a 
    by (rule assms(2)) (simp_all add: smc_op_simps)
  interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 
    rewrites "f : b ↦op_smc ℭ' a = f : a ↦ℭ' b" for ℭ' f b a
    by (rule assms(3)) (simp_all add: smc_op_simps)
  interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
  show ?thesis
  proof(rule is_semifunctorI, unfold smcf_cn_comp_components(3,4) smc_op_simps)
    from assms show "smcf_dghm (𝔊 SMCF∘ 𝔉) : smc_dg 𝔄 ↦↦DGα smc_dg ℭ"
      by 
        (
          cs_concl 
            cs_simp: slicing_commute[symmetric] 
            cs_intro: dg_cn_cs_intros slicing_intros
        )
    fix g b c f a assume "g : b ↦𝔄 c" "f : a ↦𝔄 b"
    with assms show "(𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇g ∘A𝔄 f⦈ = 
      (𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇g⦈ ∘Aℭ (𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇f⦈"
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_cn_cs_simps smc_op_simps 
            cs_intro: smc_cs_intros
        )
  qed 
    (
      auto simp: 
        smcf_cn_comp_def 
        nat_omega_simps 
        smc_cs_simps
        smc_op_simps 
        smc_cs_intros
    )
qed

lemma smcf_cn_cov_comp_is_semifunctor[smc_cs_intros]:
  ―‹See section 1.2 in \cite{bodo_categories_1970}.›
  assumes "𝔊 : 𝔅 SMC↦↦α ℭ" and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝔊 SMCF∘ 𝔉 : 𝔄 SMC↦↦α ℭ"
proof-
  interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 
    rewrites "f : b ↦op_smc ℭ' a = f : a ↦ℭ' b" for ℭ' f b a 
    by (rule assms(1)) (simp_all add: smc_op_simps)
  interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  show ?thesis
  proof(rule is_semifunctorI, unfold smcf_cn_comp_components(3,4) smc_op_simps)
    from assms show 
      "smcf_dghm (𝔊 SMCF∘ 𝔉) : smc_dg (op_smc 𝔄) ↦↦DGα smc_dg ℭ"
      by 
        (
          cs_concl 
            cs_simp: slicing_commute[symmetric]
            cs_intro: dg_cn_cs_intros slicing_intros
        )
    show "vfsequence (𝔊 SMCF∘ 𝔉)" unfolding smcf_cn_comp_def by simp
    show "vcard (𝔊 SMCF∘ 𝔉) = 4ℕ"
      unfolding smcf_cn_comp_def by (auto simp: nat_omega_simps)
    show "op_smc (𝔉⦇HomDom⦈) = op_smc 𝔄" by (simp add: smc_cs_simps)
    show "𝔊⦇HomCod⦈ = ℭ" by (simp add: smc_cs_simps)
    fix g b c f a assume "g : c ↦𝔄 b" "f : b ↦𝔄 a"
    with assms show 
      "(𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇f ∘A𝔄 g⦈ = 
        (𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇g⦈ ∘Aℭ (𝔊 SMCF∘ 𝔉)⦇ArrMap⦈⦇f⦈"
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_cn_cs_simps smc_op_simps 
            cs_intro: smc_cs_intros
        )
  qed (auto intro: smc_cs_intros smc_op_intros)
qed

lemma smcf_cov_cn_comp_is_semifunctor[smc_cn_cs_intros]:
  ―‹See section 1.2 in \cite{bodo_categories_1970}.›
  assumes "𝔊 : 𝔅 ↦↦SMCα ℭ" and "𝔉 : 𝔄 SMC↦↦α 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 SMC↦↦α ℭ"
  using assms by (rule smcf_comp_is_semifunctor)



subsection‹Identity semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

abbreviation (input) smcf_id :: "V ⇒ V" where "smcf_id ≡ dghm_id"


text‹Slicing.›

lemma smcf_dghm_smcf_id[slicing_commute]: 
  "dghm_id (smc_dg ℭ) = smcf_dghm (smcf_id ℭ)"
  unfolding dghm_id_def smc_dg_def smcf_dghm_def dghm_field_simps dg_field_simps
  by (simp add: nat_omega_simps)

context semicategory
begin

interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)

lemmas_with [unfolded slicing_simps]:
  smc_dghm_id_is_dghm = dg.dg_dghm_id_is_dghm

end


subsubsection‹Object map›

lemmas [smc_cs_simps] = dghm_id_ObjMap_app


subsubsection‹Arrow map›

lemmas [smc_cs_simps] = dghm_id_ArrMap_app


subsubsection‹Opposite identity semifunctor›

lemma op_smcf_smcf_id[smc_op_simps]: "op_smcf (smcf_id ℭ) = smcf_id (op_smc ℭ)"
  unfolding dghm_id_def op_smc_def op_smcf_def dghm_field_simps dg_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹An identity semifunctor is a semifunctor›

lemma (in semicategory) smc_smcf_id_is_semifunctor: "smcf_id ℭ : ℭ ↦↦SMCα ℭ"
proof(rule is_semifunctorI, unfold dghm_id_components)
  from smc_dghm_id_is_dghm show 
    "smcf_dghm (smcf_id ℭ) : smc_dg ℭ ↦↦DGα smc_dg ℭ"
    by (auto simp: slicing_simps slicing_commute)
  fix g b c f a assume "g : b ↦ℭ c" "f : a ↦ℭ b"
  then show "vid_on (ℭ⦇Arr⦈)⦇g ∘Aℭ f⦈ = 
    vid_on (ℭ⦇Arr⦈)⦇g⦈ ∘Aℭ vid_on (ℭ⦇Arr⦈)⦇f⦈"
    by (metis smc_is_arrD(1) smc_Comp_is_arr vid_on_eq_atI)
qed (auto simp: semicategory_axioms dghm_id_def nat_omega_simps)

lemma (in semicategory) smc_smcf_id_is_semifunctor': 
  assumes "𝔄 = ℭ" and "𝔅 = ℭ"
  shows "smcf_id ℭ : 𝔄 ↦↦SMCα 𝔅"
  unfolding assms by (rule smc_smcf_id_is_semifunctor)

lemmas [smc_cs_intros] = semicategory.smc_smcf_id_is_semifunctor'


subsubsection‹Further properties›

lemma (in is_semifunctor) smcf_smcf_comp_smcf_id_left[smc_cs_simps]:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
  "smcf_id 𝔅 ∘SMCF 𝔉 = 𝔉"
  by (rule smcf_eqI, unfold dghm_id_components dghm_comp_components)
    (auto simp: smcf_ObjMap_vrange smcf_ArrMap_vrange intro: smc_cs_intros)

lemmas [smc_cs_simps] = is_semifunctor.smcf_smcf_comp_smcf_id_left

lemma (in is_semifunctor) smcf_smcf_comp_smcf_id_right[smc_cs_simps]: 
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
  "𝔉 ∘SMCF smcf_id 𝔄 = 𝔉"
  by (rule smcf_eqI, unfold dghm_id_components dghm_comp_components)
    (
      auto 
        simp: smcf_ObjMap_vrange smcf_ArrMap_vrange smc_cs_simps
        intro: smc_cs_intros
    )

lemmas [smc_cs_simps] = is_semifunctor.smcf_smcf_comp_smcf_id_right



subsection‹Constant semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter III-3 in \cite{mac_lane_categories_2010}.›

abbreviation (input) smcf_const :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "smcf_const ≡ dghm_const"


text‹Slicing.›

lemma smcf_dghm_smcf_const[slicing_commute]: 
  "dghm_const (smc_dg ℭ) (smc_dg 𝔇) a f = smcf_dghm (smcf_const ℭ 𝔇 a f)"
  unfolding 
    dghm_const_def smc_dg_def smcf_dghm_def dghm_field_simps dg_field_simps
  by (simp add: nat_omega_simps)


subsubsection‹Object map›

lemmas [smc_cs_simps] = 
  dghm_const_ObjMap_app 


subsubsection‹Arrow map›

lemmas [smc_cs_simps] = 
  dghm_const_ArrMap_app


subsubsection‹Opposite constant semifunctor›

lemma op_smcf_smcf_const[smc_op_simps]:
  "op_smcf (smcf_const ℭ 𝔇 a f) = smcf_const (op_smc ℭ) (op_smc 𝔇) a f"
  unfolding dghm_const_def op_smc_def op_smcf_def dghm_field_simps dg_field_simps
  by (auto simp: nat_omega_simps)


subsubsection‹A constant semifunctor is a semifunctor›

lemma smcf_const_is_semifunctor: 
  assumes "semicategory α ℭ"
    and "semicategory α 𝔇" 
    and "f : a ↦𝔇 a" 
    and [simp]: "f ∘A𝔇 f = f"
  shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦SMCα 𝔇"
proof-
  interpret ℭ: semicategory α ℭ by (rule assms(1))
  interpret 𝔇: semicategory α 𝔇 by (rule assms(2))
  show ?thesis
  proof(intro is_semifunctorI, tactic‹distinct_subgoals_tac›)
    from assms show 
      "smcf_dghm (dghm_const ℭ 𝔇 a f) : smc_dg ℭ ↦↦DGα smc_dg 𝔇"
      by 
        ( 
          cs_concl 
            cs_simp: slicing_commute[symmetric] 
            cs_intro: dg_cs_intros slicing_intros
        )
    show "vfsequence (smcf_const ℭ 𝔇 a f)" unfolding dghm_const_def by simp
    show "vcard (smcf_const ℭ 𝔇 a f) = 4ℕ"
      unfolding dghm_const_def by (simp add: nat_omega_simps)
    fix g' b c f' a' assume "g' : b ↦ℭ c" "f' : a' ↦ℭ b"
    with assms(1-3) show "smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇g' ∘Aℭ f'⦈ =
      smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇g'⦈ ∘A𝔇 smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇f'⦈"
      by (cs_concl cs_simp: assms(4) smc_cs_simps cs_intro: smc_cs_intros)
  qed (auto simp: assms(1,2) dghm_const_components)
qed 

lemma smcf_const_is_semifunctor'[smc_cs_intros]: 
  assumes "semicategory α ℭ" 
    and "semicategory α 𝔇" 
    and "f : a ↦𝔇 a"
    and "f ∘A𝔇 f = f"
    and "𝔄 = ℭ"
    and "𝔅 = 𝔇"
  shows "smcf_const ℭ 𝔇 a f : 𝔄 ↦↦SMCα 𝔅"
  using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_semifunctor)



subsection‹Faithful semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_ft_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 + 
  assumes ft_smcf_is_ft_dghm: 
    "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.faithfulα smc_dg 𝔅"

syntax "_is_ft_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMC.faithfulı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.faithfulα 𝔅" ⇌ "CONST is_ft_semifunctor α 𝔄 𝔅 𝔉"

lemma (in is_ft_semifunctor) ft_smcf_is_ft_dghm'[slicing_intros]:
  assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DG.faithfulα 𝔅'"
  unfolding assms by (rule ft_smcf_is_ft_dghm)

lemmas [slicing_intros] = is_ft_semifunctor.ft_smcf_is_ft_dghm'


text‹Rules.›

lemma (in is_ft_semifunctor) is_ft_semifunctor_axioms'[smcf_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦SMC.faithfulα' 𝔅'"
  unfolding assms by (rule is_ft_semifunctor_axioms)

mk_ide rf is_ft_semifunctor_def[unfolded is_ft_semifunctor_axioms_def]
  |intro is_ft_semifunctorI|
  |dest is_ft_semifunctorD[dest]|
  |elim is_ft_semifunctorE[elim]|

lemmas [smcf_cs_intros] = is_ft_semifunctorD(1)

lemma is_ft_semifunctorI':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"
  shows "𝔉 : 𝔄 ↦↦SMC.faithfulα 𝔅"
  using assms
  by (intro is_ft_semifunctorI)
    (
      simp_all add: 
        assms(1) 
        is_ft_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
    )

lemma is_ft_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMC.faithfulα 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"
  by 
    (
      simp_all add: 
        is_ft_semifunctorD[OF assms(1)] 
        is_ft_dghmD(2)[
          OF is_ft_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
          ]
    )

lemma is_ft_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMC.faithfulα 𝔅"
  obtains "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾l∘ Hom 𝔄 a b)"
  using assms by (simp_all add: is_ft_semifunctorD')


text‹Elementary properties.›

context is_ft_semifunctor
begin

interpretation dghm: is_ft_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule ft_smcf_is_ft_dghm) 

lemmas_with [unfolded slicing_simps]:
  ft_smcf_v11_on_Hom = dghm.ft_dghm_v11_on_Hom

end


subsubsection‹Opposite faithful semifunctor›

lemma (in is_ft_semifunctor) is_ft_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.faithfulα op_smc 𝔅"   
  by 
    (
      rule is_ft_semifunctorI, 
      unfold smc_op_simps slicing_simps slicing_commute[symmetric]
    )
    (
      simp_all add: 
        is_semifunctor_op is_ft_dghm.ft_dghm_op_dghm_is_ft_dghm 
        ft_smcf_is_ft_dghm
    )

lemma (in is_ft_semifunctor) is_ft_semifunctor_op'[smc_op_intros]: 
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMC.faithfulα 𝔅'"
  unfolding assms by (rule is_ft_semifunctor_op)

lemmas is_ft_semifunctor_op[smc_op_intros] = 
  is_ft_semifunctor.is_ft_semifunctor_op'


subsubsection‹
The composition of faithful semifunctors is a faithful semifunctor
›

lemma smcf_comp_is_ft_semifunctor[smcf_cs_intros]:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
  assumes "𝔊 : 𝔅 ↦↦SMC.faithfulα ℭ" and "𝔉 : 𝔄 ↦↦SMC.faithfulα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.faithfulα ℭ"
proof(intro is_ft_semifunctorI)
  interpret 𝔊: is_ft_semifunctor α 𝔅 ℭ 𝔊 by (simp add: assms(1))
  interpret 𝔉: is_ft_semifunctor α 𝔄 𝔅 𝔉 by (simp add: assms(2))
  from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show 𝔊𝔉: 
    "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ"
    by (auto intro: smc_cs_intros)
  then interpret is_semifunctor α 𝔄 ℭ ‹𝔊 ∘SMCF 𝔉› .
  show "smcf_dghm (𝔊 ∘SMCF 𝔉) : smc_dg 𝔄 ↦↦DG.faithfulα smc_dg ℭ"
    unfolding slicing_simps slicing_commute[symmetric] 
    by (auto intro: dghm_cs_intros slicing_intros)
qed



subsection‹Full semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_fl_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 + 
  assumes fl_smcf_is_fl_dghm:
    "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.fullα smc_dg 𝔅"

syntax "_is_fl_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMC.fullı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.fullα 𝔅" ⇌ "CONST is_fl_semifunctor α 𝔄 𝔅 𝔉"

lemma (in is_fl_semifunctor) fl_smcf_is_fl_dghm'[slicing_intros]:
  assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DG.fullα 𝔅'"
  unfolding assms by (rule fl_smcf_is_fl_dghm)

lemmas [slicing_intros] = is_fl_semifunctor.fl_smcf_is_fl_dghm'


text‹Rules.›

mk_ide rf is_fl_semifunctor_def[unfolded is_fl_semifunctor_axioms_def]
  |intro is_fl_semifunctorI|
  |dest is_fl_semifunctorD[dest]|
  |elim is_fl_semifunctorE[elim]|

lemmas [smcf_cs_intros] = is_fl_semifunctorD(1)

lemma is_fl_semifunctorI':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹
      𝔉⦇ArrMap⦈ `∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
  shows "𝔉 : 𝔄 ↦↦SMC.fullα 𝔅"
  using assms
  by (intro is_fl_semifunctorI)
    (
      simp_all add: 
        assms(1) 
        is_fl_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
    )

lemma is_fl_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMC.fullα 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ 
      𝔉⦇ArrMap⦈ `∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
  by 
    (
      simp_all add: 
        is_fl_semifunctorD[OF assms(1)] 
        is_fl_dghmD(2)[
          OF is_fl_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
          ]
    )

lemma is_fl_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMC.fullα 𝔅"
  obtains "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "⋀a b. ⟦ a ∈∘ 𝔄⦇Obj⦈; b ∈∘ 𝔄⦇Obj⦈ ⟧ ⟹ 
      𝔉⦇ArrMap⦈ `∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
  using assms by (simp_all add: is_fl_semifunctorD')


text‹Elementary properties.›

context is_fl_semifunctor
begin

interpretation dghm: is_fl_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule fl_smcf_is_fl_dghm) 

lemmas_with [unfolded slicing_simps]:
  fl_smcf_surj_on_Hom = dghm.fl_dghm_surj_on_Hom

end


subsubsection‹Opposite full semifunctor›

lemma (in is_fl_semifunctor) is_fl_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.fullα op_smc 𝔅"    
  by 
    (
      rule is_fl_semifunctorI, 
      unfold smc_op_simps slicing_simps slicing_commute[symmetric]
    )
    (
      simp_all add: 
        is_semifunctor_op 
        is_fl_dghm.fl_dghm_op_dghm_is_fl_dghm 
        fl_smcf_is_fl_dghm
    )

lemma (in is_fl_semifunctor) is_fl_semifunctor_op'[smc_op_intros]: 
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMC.fullα 𝔅'"
  unfolding assms by (rule is_fl_semifunctor_op)

lemmas is_fl_semifunctor_op[smc_op_intros] = 
  is_fl_semifunctor.is_fl_semifunctor_op


subsubsection‹The composition of full semifunctors is a full semifunctor›

lemma smcf_comp_is_fl_semifunctor[smcf_cs_intros]:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
  assumes "𝔊 : 𝔅 ↦↦SMC.fullα ℭ" and "𝔉 : 𝔄 ↦↦SMC.fullα 𝔅" 
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.fullα ℭ"
proof(intro is_fl_semifunctorI)
  interpret 𝔉: is_fl_semifunctor α 𝔄 𝔅 𝔉 using assms(2) by simp
  interpret 𝔊: is_fl_semifunctor α 𝔅 ℭ 𝔊 using assms(1) by simp
  from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show
    "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ" 
    by (auto intro: smc_cs_intros)
  show "smcf_dghm (𝔊 ∘DGHM 𝔉) : smc_dg 𝔄 ↦↦DG.fullα smc_dg ℭ"
    unfolding slicing_commute[symmetric] 
    by (auto intro: dghm_cs_intros slicing_intros)
qed 



subsection‹Fully faithful semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›

locale is_ff_semifunctor = 
  is_ft_semifunctor α 𝔄 𝔅 𝔉 + is_fl_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉

syntax "_is_ff_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMC.ffı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.ffα 𝔅" ⇌ "CONST is_ff_semifunctor α 𝔄 𝔅 𝔉"


text‹Rules.›

mk_ide rf is_ff_semifunctor_def
  |intro is_ff_semifunctorI|
  |dest is_ff_semifunctorD[dest]|
  |elim is_ff_semifunctorE[elim]|

lemmas [smcf_cs_intros] = is_ff_semifunctorD


text‹Elementary properties.›

lemma (in is_ff_semifunctor) ff_smcf_is_ff_dghm:
  "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.ffα smc_dg 𝔅"
  by (rule is_ff_dghmI) (auto intro: slicing_intros)

lemma (in is_ff_semifunctor) ff_smcf_is_ff_dghm'[slicing_intros]:
  assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DG.ffα 𝔅'"
  unfolding assms by (rule ff_smcf_is_ff_dghm)

lemmas [slicing_intros] = is_ff_semifunctor.ff_smcf_is_ff_dghm'


subsubsection‹Opposite fully faithful semifunctor›

lemma (in is_ff_semifunctor) is_ff_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.ffα op_smc 𝔅"    
  by (rule is_ff_semifunctorI) 
    (auto simp: is_fl_semifunctor_op is_ft_semifunctor_op)

lemma (in is_ff_semifunctor) is_ff_semifunctor_op'[smc_op_intros]: 
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMC.ffα 𝔅'"
  unfolding assms by (rule is_ff_semifunctor_op)

lemmas is_ff_semifunctor_op[smc_op_intros] = 
  is_ff_semifunctor.is_ff_semifunctor_op'


subsubsection‹
The composition of fully faithful semifunctors is a fully faithful
semifunctor
›

lemma smcf_comp_is_ff_semifunctor[smcf_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦SMC.ffα ℭ" and "𝔉 : 𝔄 ↦↦SMC.ffα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.ffα ℭ"
  using assms 
  by (intro is_ff_semifunctorI, elim is_ff_semifunctorE) 
    (auto intro: smcf_cs_intros)



subsection‹Isomorphism of semicategories›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale is_iso_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 + 
  assumes iso_smcf_is_iso_dghm: 
    "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.isoα smc_dg 𝔅"

syntax "_is_iso_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMC.isoı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅" ⇌ "CONST is_iso_semifunctor α 𝔄 𝔅 𝔉"

lemma (in is_iso_semifunctor) iso_smcf_is_iso_dghm'[slicing_intros]:
  assumes "𝔄' = smc_dg 𝔄" "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DG.isoα 𝔅'"
  unfolding assms by (rule iso_smcf_is_iso_dghm)

lemmas [slicing_intros] = is_iso_semifunctor.iso_smcf_is_iso_dghm'


text‹Rules.›

lemma (in is_iso_semifunctor) is_iso_semifunctor_axioms'[smcf_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦SMC.isoα' 𝔅'"
  unfolding assms by (rule is_iso_semifunctor_axioms)

mk_ide rf is_iso_semifunctor_def[unfolded is_iso_semifunctor_axioms_def]
  |intro is_iso_semifunctorI|
  |dest is_iso_semifunctorD[dest]|
  |elim is_iso_semifunctorE[elim]|

lemma is_iso_semifunctorI':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "v11 (𝔉⦇ObjMap⦈)"
    and "v11 (𝔉⦇ArrMap⦈)"
    and "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  shows "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  using assms
  by (intro is_iso_semifunctorI)
    (
      simp_all add: 
        assms(1) 
        is_iso_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
    )

lemma is_iso_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "v11 (𝔉⦇ObjMap⦈)"
    and "v11 (𝔉⦇ArrMap⦈)"
    and "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  by 
    (
      simp_all add: 
        is_iso_semifunctorD[OF assms(1)] 
        is_iso_dghmD(2-5)[
          OF is_iso_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
          ]
    )

lemma is_iso_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  obtains "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "v11 (𝔉⦇ObjMap⦈)"
    and "v11 (𝔉⦇ArrMap⦈)"
    and "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
    and "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  using assms by (simp_all add: is_iso_semifunctorD')


text‹Elementary properties.›

context is_iso_semifunctor
begin

interpretation dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule iso_smcf_is_iso_dghm) 

lemmas_with [unfolded slicing_simps]:
  iso_smcf_ObjMap_vrange[smcf_cs_simps] = dghm.iso_dghm_ObjMap_vrange
  and iso_smcf_ArrMap_vrange[smcf_cs_simps] = dghm.iso_dghm_ArrMap_vrange

sublocale ObjMap: v11 ‹𝔉⦇ObjMap⦈›
  rewrites "𝒟∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈" and "ℛ∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
  by (rule dghm.iso_dghm_ObjMap_v11[unfolded slicing_simps]) 
    (simp_all add: smc_cs_simps smcf_cs_simps)

sublocale ArrMap: v11 ‹𝔉⦇ArrMap⦈›
  rewrites "𝒟∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈" and "ℛ∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
  by (rule dghm.iso_dghm_ArrMap_v11[unfolded slicing_simps])
    (simp_all add: smc_cs_simps smcf_cs_simps)

lemmas_with [unfolded slicing_simps]:
  iso_smcf_Obj_HomDom_if_Obj_HomCod[elim] = 
    dghm.iso_dghm_Obj_HomDom_if_Obj_HomCod
  and iso_smcf_Arr_HomDom_if_Arr_HomCod[elim] = 
    dghm.iso_dghm_Arr_HomDom_if_Arr_HomCod
  and iso_smcf_ObjMap_eqE[elim] = dghm.iso_dghm_ObjMap_eqE
  and iso_smcf_ArrMap_eqE[elim] = dghm.iso_dghm_ArrMap_eqE

end

sublocale is_iso_semifunctor ⊆ is_ff_semifunctor 
proof-
  interpret dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
    by (rule iso_smcf_is_iso_dghm) 
  show "𝔉 : 𝔄 ↦↦SMC.ffα 𝔅" by unfold_locales
qed

lemmas (in is_iso_semifunctor) iso_smcf_is_ff_semifunctor = 
  is_ff_semifunctor_axioms

lemmas [smcf_cs_intros] = is_iso_semifunctor.iso_smcf_is_ff_semifunctor


subsubsection‹Opposite isomorphism of semicategories›

lemma (in is_iso_semifunctor) is_iso_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.isoα op_smc 𝔅"   
  by 
    (
      rule is_iso_semifunctorI, 
      unfold smc_op_simps slicing_simps slicing_commute[symmetric]
    )
    (
      simp_all add: 
        is_semifunctor_op is_iso_dghm.is_iso_dghm_op iso_smcf_is_iso_dghm
    )

lemmas is_iso_semifunctor_op[smc_op_intros] =
  is_iso_semifunctor.is_iso_semifunctor_op


subsubsection‹
The composition of isomorphisms of semicategories is an isomorphism of 
semicategories
›

lemma smcf_comp_is_iso_semifunctor[smcf_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦SMC.isoα ℭ" and "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.isoα ℭ"
proof(intro is_iso_semifunctorI)
  interpret 𝔉: is_iso_semifunctor α 𝔄 𝔅 𝔉 using assms by auto
  interpret 𝔊: is_iso_semifunctor α 𝔅 ℭ 𝔊 using assms by auto
  from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show 
    "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ" 
    by (auto intro: smcf_cs_intros)
  show "smcf_dghm (𝔊 ∘DGHM 𝔉) : smc_dg 𝔄 ↦↦DG.isoα smc_dg ℭ"
    by 
      (
        auto 
          intro: dghm_cs_intros slicing_intros 
          simp: slicing_commute[symmetric]
      )
qed



subsection‹Inverse semifunctor›

abbreviation (input) inv_smcf :: "V ⇒ V"
  where "inv_smcf ≡ inv_dghm"

lemmas [smc_cs_simps] = inv_dghm_components(3,4)


text‹Slicing.›

lemma dghm_inv_smcf[slicing_commute]: 
  "inv_dghm (smcf_dghm 𝔉) = smcf_dghm (inv_smcf 𝔉)"
  unfolding smcf_dghm_def inv_dghm_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)

context is_iso_semifunctor
begin

interpretation dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule iso_smcf_is_iso_dghm) 

lemmas_with [unfolded slicing_simps slicing_commute]:
  inv_smcf_ObjMap_v11 = dghm.inv_dghm_ObjMap_v11
  and inv_smcf_ObjMap_vdomain = dghm.inv_dghm_ObjMap_vdomain
  and inv_smcf_ObjMap_app = dghm.inv_dghm_ObjMap_app
  and inv_smcf_ObjMap_vrange = dghm.inv_dghm_ObjMap_vrange
  and inv_smcf_ArrMap_v11 = dghm.inv_dghm_ArrMap_v11
  and inv_smcf_ArrMap_vdomain = dghm.inv_dghm_ArrMap_vdomain
  and inv_smcf_ArrMap_app = dghm.inv_dghm_ArrMap_app
  and inv_smcf_ArrMap_vrange = dghm.inv_dghm_ArrMap_vrange
  and iso_smcf_ObjMap_inv_smcf_ObjMap_app =
    dghm.iso_dghm_ObjMap_inv_dghm_ObjMap_app
  and iso_smcf_ArrMap_inv_smcf_ArrMap_app = 
    dghm.iso_dghm_ArrMap_inv_dghm_ArrMap_app
  and iso_smcf_HomDom_is_arr_conv = dghm.iso_dghm_HomDom_is_arr_conv
  and iso_smcf_HomCod_is_arr_conv = dghm.iso_dghm_HomCod_is_arr_conv

end

lemmas [smcf_cs_intros] = 
  is_iso_semifunctor.inv_smcf_ObjMap_v11
  is_iso_semifunctor.inv_smcf_ArrMap_v11

lemmas [smcf_cs_simps] = 
  is_iso_semifunctor.inv_smcf_ObjMap_vdomain
  is_iso_semifunctor.inv_smcf_ObjMap_app
  is_iso_semifunctor.inv_smcf_ObjMap_vrange
  is_iso_semifunctor.inv_smcf_ArrMap_vdomain
  is_iso_semifunctor.inv_smcf_ArrMap_app
  is_iso_semifunctor.inv_smcf_ArrMap_vrange
  is_iso_semifunctor.iso_smcf_ObjMap_inv_smcf_ObjMap_app
  is_iso_semifunctor.iso_smcf_ArrMap_inv_smcf_ArrMap_app



subsection‹
An isomorphism of semicategories is an isomorphism in the category ‹SemiCAT›
›

lemma is_arr_isomorphism_is_iso_semifunctor:
  ―‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔊 : 𝔅 ↦↦SMCα 𝔄"
    and "𝔊 ∘SMCF 𝔉 = smcf_id 𝔄"
    and "𝔉 ∘SMCF 𝔊 = smcf_id 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
proof-
  interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
  interpret 𝔊: is_semifunctor α 𝔅 𝔄 𝔊 by (rule assms(2))
  show ?thesis
  proof(rule is_iso_semifunctorI)
    have dg_𝔊𝔉𝔄: "smcf_dghm 𝔊 ∘DGHM smcf_dghm 𝔉 = dghm_id (smc_dg 𝔄)"
      by (simp add: assms(3) smcf_dghm_smcf_id smcf_dghm_smcf_comp)
    have dg_𝔉𝔊𝔅: "smcf_dghm 𝔉 ∘DGHM smcf_dghm 𝔊 = dghm_id (smc_dg 𝔅)"
      by (simp add: assms(4) smcf_dghm_smcf_id smcf_dghm_smcf_comp)
    from 𝔉.smcf_is_dghm 𝔊.smcf_is_dghm dg_𝔊𝔉𝔄 dg_𝔉𝔊𝔅 show 
      "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.isoα smc_dg 𝔅"
      by (rule is_arr_isomorphism_is_iso_dghm)
  qed (simp add: 𝔉.is_semifunctor_axioms)
qed

lemma is_iso_semifunctor_is_arr_isomorphism:
  assumes "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  shows [smcf_cs_intros]: "inv_smcf 𝔉 : 𝔅 ↦↦SMC.isoα 𝔄"
    and "inv_smcf 𝔉 ∘SMCF 𝔉 = smcf_id 𝔄"
    and "𝔉 ∘SMCF inv_smcf 𝔉 = smcf_id 𝔅"
proof-

  let ?𝔊 = ‹inv_smcf 𝔉›

  interpret is_iso_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))

  note is_iso_dghm = is_iso_dghm_is_arr_isomorphism[OF iso_smcf_is_iso_dghm]

  show 𝔊: "?𝔊 : 𝔅 ↦↦SMC.isoα 𝔄"
  proof
    (
      intro is_iso_semifunctorI is_semifunctorI; 
      (unfold slicing_commute[symmetric])?
    )
    show "vfsequence (inv_smcf 𝔉)" unfolding inv_dghm_def by simp
    show "vcard (inv_smcf 𝔉) = 4ℕ"
      unfolding inv_dghm_def by (simp add: nat_omega_simps)
    show inv_iso_dghm_𝔉: 
      "inv_dghm (smcf_dghm 𝔉) : smc_dg 𝔅 ↦↦DG.isoα smc_dg 𝔄"
      by (rule is_iso_dghm(1))
    show inv_dghm_𝔉: "inv_dghm (smcf_dghm 𝔉) : smc_dg 𝔅 ↦↦DGα smc_dg 𝔄"
      by (rule is_iso_dghmD(1)[OF inv_iso_dghm_𝔉])
    fix b c g a f assume prems: "g : b ↦𝔅 c" "f : a ↦𝔅 b"
    note is_arr_inv = is_dghm.dghm_ArrMap_is_arr[
        OF inv_dghm_𝔉, unfolded slicing_simps slicing_commute
        ]
    from prems is_arr_inv[OF prems(1)] is_arr_inv[OF prems(2)] show 
      "inv_smcf 𝔉⦇ArrMap⦈⦇g ∘A𝔅 f⦈ =
        inv_smcf 𝔉⦇ArrMap⦈⦇g⦈ ∘A𝔄 inv_smcf 𝔉⦇ArrMap⦈⦇f⦈"
       unfolding inv_dghm_components
       by (intro v11.v11_vconverse_app)
         (
           cs_concl 
            cs_intro: smc_cs_intros V_cs_intros
            cs_simp: V_cs_simps smc_cs_simps
         )+
  qed (auto simp: smc_cs_simps intro: smc_cs_intros)

  show "?𝔊 ∘SMCF 𝔉 = smcf_id 𝔄"
  proof(rule smcf_eqI, unfold dghm_comp_components inv_dghm_components)
    from 𝔊 is_semifunctor_axioms show "inv_smcf 𝔉 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα 𝔄"
      by (blast intro: smc_cs_intros)
  qed
    (
      simp_all add: 
        HomDom.smc_smcf_id_is_semifunctor
        ObjMap.v11_vcomp_vconverse 
        ArrMap.v11_vcomp_vconverse 
        dghm_id_components
    )

  show "𝔉 ∘SMCF inv_smcf 𝔉 = smcf_id 𝔅"
  proof(rule smcf_eqI, unfold dghm_comp_components inv_dghm_components)
    from 𝔊 is_semifunctor_axioms show "𝔉 ∘SMCF inv_smcf 𝔉 : 𝔅 ↦↦SMCα 𝔅"
      by (blast intro: smc_cs_intros)
  qed 
    (
      simp_all add: 
        HomCod.smc_smcf_id_is_semifunctor
        ObjMap.v11_vcomp_vconverse' 
        ArrMap.v11_vcomp_vconverse' 
        dghm_id_components
    )

qed


subsubsection‹An identity semifunctor is an isomorphism of semicategories›

lemma (in semicategory) smc_smcf_id_is_iso_semifunctor: 
  "smcf_id ℭ : ℭ ↦↦SMC.isoα ℭ"
  by (rule is_iso_semifunctorI, unfold slicing_simps slicing_commute[symmetric])
    (
      simp_all add: 
        smc_smcf_id_is_semifunctor digraph.dg_dghm_id_is_iso_dghm smc_digraph
    )

lemma (in semicategory) smc_smcf_id_is_iso_semifunctor'[smcf_cs_intros]: 
  assumes "𝔄' = ℭ" and "𝔅' = ℭ"
  shows "smcf_id ℭ : 𝔄' ↦↦SMC.isoα 𝔅'"
  unfolding assms by (rule smc_smcf_id_is_iso_semifunctor)

lemmas [smcf_cs_intros] = semicategory.smc_smcf_id_is_iso_semifunctor'



subsection‹Isomorphic semicategories›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›

locale iso_semicategory = L: semicategory α 𝔄 + R: semicategory α 𝔅 
  for α 𝔄 𝔅 +
  assumes iso_smc_is_iso_semifunctor: "∃𝔉. 𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"

notation iso_semicategory (infixl "≈SMCı" 50)


text‹Rules.›

lemma iso_semicategoryI:
  assumes "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅" 
  shows "𝔄 ≈SMCα 𝔅"
  using assms 
  unfolding iso_semicategory_def iso_semicategory_axioms_def 
  by blast

lemma iso_semicategoryD[dest]:
  assumes "𝔄 ≈SMCα 𝔅" 
  shows "∃𝔉. 𝔉 : 𝔄 ↦↦SMC.isoα 𝔅" 
  using assms 
  unfolding iso_semicategory_def iso_semicategory_axioms_def 
  by simp_all

lemma iso_semicategoryE[elim]:
  assumes "𝔄 ≈SMCα 𝔅" 
  obtains 𝔉 where "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅"
  using assms by auto


text‹Elementary properties.›

lemma (in iso_semicategory) iso_smc_iso_digraph: "smc_dg 𝔄 ≈DGα smc_dg 𝔅"
  using iso_smc_is_iso_semifunctor 
  by (auto intro: slicing_intros iso_digraphI)


subsubsection‹A semicategory isomorphism is an equivalence relation›

lemma iso_semicategory_refl: 
  assumes "semicategory α 𝔄" 
  shows "𝔄 ≈SMCα 𝔄"
proof(rule iso_semicategoryI[of _  _ _ ‹smcf_id 𝔄›])
  interpret semicategory α 𝔄 by (rule assms)
  show "smcf_id 𝔄 : 𝔄 ↦↦SMC.isoα 𝔄"  
    by (simp add: smc_smcf_id_is_iso_semifunctor)
qed

lemma iso_semicategory_sym[sym]:
  assumes "𝔄 ≈SMCα 𝔅" 
  shows "𝔅 ≈SMCα 𝔄"
proof-
  interpret iso_semicategory α 𝔄 𝔅 by (rule assms)
  from iso_smc_is_iso_semifunctor obtain 𝔉 where "𝔉 : 𝔄 ↦↦SMC.isoα 𝔅" 
    by clarsimp
  then have "inv_smcf 𝔉 : 𝔅 ↦↦SMC.isoα 𝔄" 
    by (simp add: is_iso_semifunctor_is_arr_isomorphism(1))
  then show ?thesis by (auto intro: iso_semicategoryI)
qed

lemma iso_semicategory_trans[trans]:
  assumes "𝔄 ≈SMCα 𝔅" and "𝔅 ≈SMCα ℭ" 
  shows "𝔄 ≈SMCα ℭ"
proof-  
  interpret L: iso_semicategory α 𝔄 𝔅 by (rule assms(1))
  interpret R: iso_semicategory α 𝔅 ℭ by (rule assms(2))
  from L.iso_smc_is_iso_semifunctor R.iso_smc_is_iso_semifunctor show ?thesis
    by (auto intro: iso_semicategoryI smcf_cs_intros)
qed

text‹\newpage›

end

Theory CZH_SMC_Small_Semifunctor

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for semifunctors›
theory CZH_SMC_Small_Semifunctor
  imports 
    CZH_DG_Small_DGHM
    CZH_SMC_Semifunctor
    CZH_SMC_Small_Semicategory
begin



subsection‹Semifunctor with tiny maps›


subsubsection‹Definition and elementary properties›

locale is_tm_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
  assumes tm_smcf_is_tm_dghm[slicing_intros]: 
    "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.tmα smc_dg 𝔅" 

syntax "_is_tm_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ ↦↦SMC.tmı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅" ⇌ "CONST is_tm_semifunctor α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_tm_semifunctor :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_tm_semifunctor α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦SMC.tmα 𝔅"

syntax "_is_cn_tm_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ SMC.tm↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 SMC.tm↦↦α 𝔅" ⇀ "CONST is_cn_tm_semifunctor α 𝔄 𝔅 𝔉"

abbreviation all_tm_smcfs :: "V ⇒ V"
  where "all_tm_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tmα 𝔅}"

abbreviation small_tm_smcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "small_tm_smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦SMC.tmα 𝔅}"

lemma (in is_tm_semifunctor) tm_smcf_is_tm_dghm':
  assumes "α' = α"
    and "𝔄' = smc_dg 𝔄"
    and "𝔅' = smc_dg 𝔅"
  shows "smcf_dghm 𝔉 : 𝔄' ↦↦DG.tmα' 𝔅'"
  unfolding assms by (rule tm_smcf_is_tm_dghm)

lemmas [slicing_intros] = is_tm_semifunctor.tm_smcf_is_tm_dghm'


text‹Rules.›

lemma (in is_tm_semifunctor) is_tm_semifunctor_axioms'[smc_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦SMC.tmα' 𝔅'"
  unfolding assms by (rule is_tm_semifunctor_axioms)

mk_ide rf is_tm_semifunctor_def[unfolded is_tm_semifunctor_axioms_def]
  |intro is_tm_semifunctorI|
  |dest is_tm_semifunctorD[dest]|
  |elim is_tm_semifunctorE[elim]|

lemmas [smc_small_cs_intros] = is_tm_semifunctorD(1)


text‹Slicing.›

context is_tm_semifunctor
begin

interpretation dghm: is_tm_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
  by (rule tm_smcf_is_tm_dghm)

lemmas_with [unfolded slicing_simps]:
  tm_smcf_ObjMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ObjMap_in_Vset
  and tm_smcf_ArrMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ArrMap_in_Vset

end


text‹Elementary properties.›

sublocale is_tm_semifunctor ⊆ HomDom: tiny_semicategory α 𝔄 
proof(rule tiny_semicategoryI')
  show "𝔄⦇Obj⦈ ∈∘ Vset α"
    by (rule vdomain_in_VsetI[OF tm_smcf_ObjMap_in_Vset, unfolded smc_cs_simps])
  show "𝔄⦇Arr⦈ ∈∘ Vset α"
    by (rule vdomain_in_VsetI[OF tm_smcf_ArrMap_in_Vset, unfolded smc_cs_simps])
qed (simp add: smc_cs_intros)


text‹Further rules.›

lemma is_tm_semifunctorI':
  assumes [simp]: "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and [simp]: "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and [simp]: "𝔉⦇ArrMap⦈ ∈∘ Vset α"
    and [simp]: "semicategory α 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
proof(intro is_tm_semifunctorI)
  interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
  show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.tmα smc_dg 𝔅"
    by (intro is_tm_dghmI', unfold slicing_simps) (auto simp: slicing_intros)
qed simp_all

lemma is_tm_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "semicategory α 𝔅"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and "𝔉⦇ArrMap⦈ ∈∘ Vset α"
proof-
  interpret is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))    
  show "semicategory α 𝔅"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and "𝔉⦇ArrMap⦈ ∈∘ Vset α"
    by (auto intro: smc_cs_intros smc_small_cs_intros)
qed

lemmas [smc_small_cs_intros] = is_tm_semifunctorD'(1)

lemma is_tm_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
  obtains "semicategory α 𝔅"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔉⦇ObjMap⦈ ∈∘ Vset α"
    and "𝔉⦇ArrMap⦈ ∈∘ Vset α"
  using is_tm_semifunctorD'[OF assms] by simp


text‹Size.›

lemma small_all_tm_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tmα 𝔅}"
proof(rule down)
  show 
    "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tmα 𝔅} ⊆
      elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_smcfs if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
    then obtain 𝔄 𝔅 where "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅" by clarsimp
    then interpret is_tm_semifunctor α 𝔄 𝔅 𝔉 by simp
    show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅" by (auto intro: is_semifunctor_axioms)
  qed
qed


subsubsection‹Opposite semifunctor with tiny maps›

lemma (in is_tm_semifunctor) is_tm_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.tmα op_smc 𝔅"
  by (intro is_tm_semifunctorI', unfold smc_op_simps)
    (cs_concl cs_intro: smc_cs_intros smc_op_intros smc_small_cs_intros)

lemma (in is_tm_semifunctor) is_tm_semifunctor_op'[smc_op_intros]:  
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMC.tmα' 𝔅'"
  unfolding assms by (rule is_tm_semifunctor_op)

lemmas is_tm_semifunctor_op[smc_op_intros] = is_tm_semifunctor.is_tm_semifunctor_op'


subsubsection‹Composition of semifunctors with tiny maps›

lemma smcf_comp_is_tm_semifunctor[smc_small_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦SMC.tmα ℭ" and "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.tmα ℭ"
proof(rule is_tm_semifunctorI)
  interpret 𝔉: is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  interpret 𝔊: is_tm_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
  show "smcf_dghm (𝔊 ∘SMCF 𝔉) : smc_dg 𝔄 ↦↦DG.tmα smc_dg ℭ"
    unfolding slicing_commute[symmetric] 
    using 𝔉.tm_smcf_is_tm_dghm 𝔊.tm_smcf_is_tm_dghm  
    by (auto simp: dg_small_cs_intros)
  show "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ" by (auto intro: smc_cs_intros)
qed


subsubsection‹Finite semicategories and semifunctors with tiny maps›

lemma (in is_semifunctor) smcf_is_tm_semifunctor_if_HomDom_finite_semicategory:
  assumes "finite_semicategory α 𝔄"
  shows "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
proof(intro is_tm_semifunctorI)
  interpret 𝔄: finite_semicategory α 𝔄 by (rule assms(1))
  show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.tmα smc_dg 𝔅"
    by 
      (
        rule is_dghm.dghm_is_tm_dghm_if_HomDom_finite_digraph[
          OF smcf_is_dghm 𝔄.fin_smc_finite_digraph
          ]
      )
qed (auto intro: smc_cs_intros)


subsubsection‹Constant semifunctor with tiny maps›

lemma smcf_const_is_tm_semifunctor: 
  assumes "tiny_semicategory α ℭ"
    and "semicategory α 𝔇" 
    and "f : a ↦𝔇 a"
    and "f ∘A𝔇 f = f"
  shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦SMC.tmα 𝔇"
proof(intro is_tm_semifunctorI)
  interpret ℭ: tiny_semicategory α ℭ by (rule assms(1))
  interpret 𝔇: semicategory α 𝔇 by (rule assms(2))
  show "smcf_dghm (smcf_const ℭ 𝔇 a f) : smc_dg ℭ ↦↦DG.tmα smc_dg 𝔇"
    unfolding slicing_commute[symmetric]
    by (rule dghm_const_is_tm_dghm) 
      (auto simp: slicing_simps ℭ.tiny_smc_tiny_digraph assms(3) 𝔇.smc_digraph)
  from assms show "smcf_const ℭ 𝔇 a f : ℭ ↦↦SMCα 𝔇"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed

lemma smcf_const_is_tm_semifunctor':
  assumes "tiny_semicategory α ℭ"
    and "semicategory α 𝔇" 
    and "f : a ↦𝔇 a"
    and "f ∘A𝔇 f = f"
    and "ℭ' = ℭ"
    and "𝔇' = 𝔇"
  shows "smcf_const ℭ 𝔇 a f : ℭ' ↦↦SMC.tmα 𝔇'"
  using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tm_semifunctor)

lemmas [smc_small_cs_intros] = smcf_const_is_tm_semifunctor'



subsection‹Tiny semifunctor›


subsubsection‹Definition and elementary properties›

locale is_tiny_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 + 
  assumes tiny_smcf_is_tiny_dghm[slicing_intros]: 
    "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.tinyα smc_dg 𝔅"

syntax "_is_tiny_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦↦SMC.tinyı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅" ⇌ "CONST is_tiny_semifunctor α 𝔄 𝔅 𝔉"

abbreviation (input) is_cn_tiny_smcf :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
  where "is_cn_tiny_smcf α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_smc 𝔄 ↦↦SMC.tinyα 𝔅"

syntax "_is_cn_tiny_smcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" 
  (‹(_ :/ _ SMC.tiny↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 SMC.tiny↦↦α 𝔅" ⇀ "CONST is_cn_tiny_smcf α 𝔄 𝔅 𝔉"

abbreviation all_tiny_smcfs :: "V ⇒ V"
  where "all_tiny_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅}"

abbreviation tiny_smcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "tiny_smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅}"

lemmas [slicing_intros] = is_tiny_semifunctor.tiny_smcf_is_tiny_dghm


text‹Rules.›

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_axioms'[smc_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
  shows "𝔉 : 𝔄' ↦↦SMC.tinyα' 𝔅'"
  unfolding assms by (rule is_tiny_semifunctor_axioms)

mk_ide rf is_tiny_semifunctor_def[unfolded is_tiny_semifunctor_axioms_def]
  |intro is_tiny_semifunctorI|
  |dest is_tiny_semifunctorD[dest]|
  |elim is_tiny_semifunctorE[elim]|

lemmas [smc_small_cs_intros] = is_tiny_semifunctorD(1)


text‹Elementary properties.›

sublocale is_tiny_semifunctor ⊆ HomDom: tiny_semicategory α 𝔄
proof(intro tiny_semicategoryI')
  interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
    by (rule tiny_smcf_is_tiny_dghm)
  show "𝔄⦇Obj⦈ ∈∘ Vset α"
    by (rule dghm.HomDom.tiny_dg_Obj_in_Vset[unfolded slicing_simps])    
  show "𝔄⦇Arr⦈ ∈∘ Vset α"
    by (rule dghm.HomDom.tiny_dg_Arr_in_Vset[unfolded slicing_simps])    
qed (auto simp: smc_cs_intros)

sublocale is_tiny_semifunctor ⊆ HomCod: tiny_semicategory α 𝔅
proof(intro tiny_semicategoryI')
  interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
    by (rule tiny_smcf_is_tiny_dghm)
  show "𝔅⦇Obj⦈ ∈∘ Vset α"
    by (rule dghm.HomCod.tiny_dg_Obj_in_Vset[unfolded slicing_simps])    
  show "𝔅⦇Arr⦈ ∈∘ Vset α"
    by (rule dghm.HomCod.tiny_dg_Arr_in_Vset[unfolded slicing_simps])    
qed (auto simp: smc_cs_intros)

sublocale is_tiny_semifunctor ⊆ is_tm_semifunctor
proof(intro is_tm_semifunctorI')
  interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
    by (rule tiny_smcf_is_tiny_dghm)
  note Vset[unfolded slicing_simps] = 
    dghm.tiny_dghm_ObjMap_in_Vset
    dghm.tiny_dghm_ArrMap_in_Vset
  show "𝔉⦇ObjMap⦈ ∈∘ Vset α" "𝔉⦇ArrMap⦈ ∈∘ Vset α" by (intro Vset)+
qed (auto simp: smc_cs_intros)


text‹Further rules.›

lemma is_tiny_semifunctorI':
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "tiny_semicategory α 𝔄"
    and "tiny_semicategory α 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
  using assms 
  by 
    (
      auto simp: 
        smc_cs_simps 
        smc_cs_intros 
        is_semifunctor.smcf_is_dghm 
        is_tiny_dghm.intro 
        is_tiny_semifunctorI 
        tiny_semicategory.tiny_smc_tiny_digraph
    )

lemma is_tiny_semifunctorD':
  assumes "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "tiny_semicategory α 𝔄"
    and "tiny_semicategory α 𝔅"
proof-
  interpret is_tiny_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
  show "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "tiny_semicategory α 𝔄" 
    and "tiny_semicategory α 𝔅"
    by (auto intro: smc_small_cs_intros)
qed

lemmas [smc_small_cs_intros] = is_tiny_semifunctorD'(2,3)

lemma is_tiny_semifunctorE':
  assumes "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
  obtains "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    and "tiny_semicategory α 𝔄"
    and "tiny_semicategory α 𝔅"
  using is_tiny_semifunctorD'[OF assms] by auto

lemma is_tiny_semifunctor_iff:
  "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅 ⟷
    (𝔉 : 𝔄 ↦↦SMCα 𝔅 ∧ tiny_semicategory α 𝔄 ∧ tiny_semicategory α 𝔅)"
  by (auto intro: is_tiny_semifunctorI' dest: is_tiny_semifunctorD'(2,3))


text‹Size.›

lemma (in is_tiny_semifunctor) tiny_smcf_in_Vset: "𝔉 ∈∘ Vset α"
proof-
  note [smc_cs_intros] = 
    tm_smcf_ObjMap_in_Vset 
    tm_smcf_ArrMap_in_Vset
    HomDom.tiny_smc_in_Vset 
    HomCod.tiny_smc_in_Vset 
  show ?thesis
    by (subst smcf_def) 
      (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed

lemma small_all_tiny_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅}"
proof(rule down)
  show 
    "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅} ⊆ 
      elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_smcfs if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
    then obtain 𝔄 𝔅 where "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅" by clarsimp
    then interpret is_tiny_semifunctor α 𝔄 𝔅 𝔉 by simp
    show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMCα 𝔅" using is_semifunctor_axioms by auto
  qed
qed

lemma tiny_smcfs_vsubset_Vset[simp]: 
  "set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅} ⊆∘ Vset α"
proof(rule vsubsetI)
  fix 𝔉 assume "𝔉 ∈∘ all_tiny_smcfs α"
  then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅" by clarsimp
  then show "𝔉 ∈∘ Vset α" by (auto simp: is_tiny_semifunctor.tiny_smcf_in_Vset)
qed

lemma (in is_semifunctor) smcf_is_tiny_semifunctor_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔉 : 𝔄 ↦↦SMC.tinyβ 𝔅"
proof(intro is_tiny_semifunctorI)
  show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦DG.tinyβ smc_dg 𝔅"
    by 
      (
        rule is_dghm.dghm_is_tiny_dghm_if_ge_Limit, 
        rule smcf_is_dghm; 
        intro assms
      )
qed (simp add: smcf_is_semifunctor_if_ge_Limit assms)


subsubsection‹Opposite tiny semifunctor›

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op: 
  "op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.tinyα op_smc 𝔅"
  by (intro is_tiny_semifunctorI') 
    (cs_concl cs_intro: smc_small_cs_intros smc_op_intros)+

lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op'[smc_op_intros]:  
  assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
  shows "op_smcf 𝔉 : 𝔄' ↦↦SMC.tinyα' 𝔅'"
  unfolding assms by (rule is_tiny_semifunctor_op)

lemmas is_tiny_semifunctor_op[smc_op_intros] = 
  is_tiny_semifunctor.is_tiny_semifunctor_op'


subsubsection‹Composition of tiny semifunctors›

lemma smcf_comp_is_tiny_semifunctor[smc_small_cs_intros]:
  assumes "𝔊 : 𝔅 ↦↦SMC.tinyα ℭ" and "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
  shows "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMC.tinyα ℭ"
proof-
  interpret 𝔉: is_tiny_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  interpret 𝔊: is_tiny_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
  show ?thesis 
    by (rule is_tiny_semifunctorI') 
      (cs_concl cs_intro: smc_cs_intros smc_small_cs_intros)
qed


subsubsection‹Tiny constant semifunctor›

lemma smcf_const_is_tiny_semifunctor:
  assumes "tiny_semicategory α ℭ" 
    and "tiny_semicategory α 𝔇" 
    and "f : a ↦𝔇 a"
    and "f ∘A𝔇 f = f"
  shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦SMC.tinyα 𝔇"
proof(intro is_tiny_semifunctorI')
  from assms show "smcf_const ℭ 𝔇 a f : ℭ ↦↦SMCα 𝔇"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_small_cs_intros)
qed (auto simp: assms(1,2))

lemma smcf_const_is_tiny_semifunctor'[smc_small_cs_intros]:
  assumes "tiny_semicategory α ℭ"
    and "tiny_semicategory α 𝔇" 
    and "f : a ↦𝔇 a"
    and "f ∘A𝔇 f = f"
    and "ℭ' = ℭ"
    and "𝔇' = 𝔇"
  shows "smcf_const ℭ 𝔇 a f : ℭ' ↦↦SMC.tinyα 𝔇'"
  using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tiny_semifunctor)

text‹\newpage›

end

Theory CZH_SMC_NTSMCF

(* Copyright 2021 (C) Mihails Milehins *)

section‹Natural transformation of a semifunctor›
theory CZH_SMC_NTSMCF
  imports 
    CZH_SMC_Semifunctor
    CZH_DG_TDGHM
begin



subsection‹Background›

named_theorems ntsmcf_cs_simps
named_theorems ntsmcf_cs_intros

lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros


subsubsection‹Slicing›

definition ntsmcf_tdghm :: "V ⇒ V"
  where "ntsmcf_tdghm 𝔑 = 
    [
      𝔑⦇NTMap⦈, 
      smcf_dghm (𝔑⦇NTDom⦈),
      smcf_dghm (𝔑⦇NTCod⦈),
      smc_dg (𝔑⦇NTDGDom⦈),
      smc_dg (𝔑⦇NTDGCod⦈)
    ]∘"


text‹Components.›

lemma ntsmcf_tdghm_components:
  shows [slicing_simps]: "ntsmcf_tdghm 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
    and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDom⦈ = smcf_dghm (𝔑⦇NTDom⦈)"
    and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTCod⦈ = smcf_dghm (𝔑⦇NTCod⦈)"
    and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDGDom⦈ = smc_dg (𝔑⦇NTDGDom⦈)"
    and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDGCod⦈ = smc_dg (𝔑⦇NTDGCod⦈)"
  unfolding ntsmcf_tdghm_def nt_field_simps by (auto simp: nat_omega_simps)



subsection‹Definition and elementary properties›


text‹
A natural transformation of semifunctors, as presented in this work,
is a generalization of the concept of a natural transformation, as presented in
Chapter I-4 in \cite{mac_lane_categories_2010}, to semicategories and
semifunctors.
›

locale is_ntsmcf = 
  𝒵 α + 
  vfsequence 𝔑 + 
  NTDom: is_semifunctor α 𝔄 𝔅 𝔉 + 
  NTCod: is_semifunctor α 𝔄 𝔅 𝔊
  for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
  assumes ntsmcf_length[smc_cs_simps]: "vcard 𝔑 = 5ℕ"  
    and ntsmcf_is_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
      smcf_dghm 𝔉 ↦DGHM smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DGα smc_dg 𝔅"
    and ntsmcf_NTDom[smc_cs_simps]: "𝔑⦇NTDom⦈ = 𝔉"
    and ntsmcf_NTCod[smc_cs_simps]: "𝔑⦇NTCod⦈ = 𝔊"
    and ntsmcf_NTDGDom[smc_cs_simps]: "𝔑⦇NTDGDom⦈ = 𝔄"
    and ntsmcf_NTDGCod[smc_cs_simps]: "𝔑⦇NTDGCod⦈ = 𝔅"
    and ntsmcf_Comp_commute[smc_cs_intros]: "f : a ↦𝔄 b ⟹
      𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈" 

syntax "_is_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦SMCF _ :/ _ ↦↦SMCı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" ⇌ 
  "CONST is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_ntsmcfs :: "V ⇒ V"
  where "all_ntsmcfs α ≡ set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"

abbreviation ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "ntsmcfs α 𝔄 𝔅 ≡ set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"

abbreviation these_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡ set {𝔑. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"

lemmas [smc_cs_simps] =
  is_ntsmcf.ntsmcf_length
  is_ntsmcf.ntsmcf_NTDom
  is_ntsmcf.ntsmcf_NTCod
  is_ntsmcf.ntsmcf_NTDGDom
  is_ntsmcf.ntsmcf_NTDGCod
  is_ntsmcf.ntsmcf_Comp_commute

lemmas [smc_cs_intros] = is_ntsmcf.ntsmcf_Comp_commute

lemma (in is_ntsmcf) ntsmcf_is_tdghm':
  assumes "𝔉' = smcf_dghm 𝔉"
    and "𝔊' = smcf_dghm 𝔊"
    and "𝔄' = smc_dg 𝔄"
    and "𝔅' = smc_dg 𝔅"
  shows "ntsmcf_tdghm 𝔑 : 𝔉' ↦DGHM 𝔊' : 𝔄' ↦↦DGα 𝔅'"
  unfolding assms(1-4) by (rule ntsmcf_is_tdghm)

lemmas [slicing_intros] = is_ntsmcf.ntsmcf_is_tdghm'


text‹Rules.›

lemma (in is_ntsmcf) is_ntsmcf_axioms'[smc_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "𝔑 : 𝔉' ↦SMCF 𝔊' : 𝔄' ↦↦SMCα' 𝔅'"
  unfolding assms by (rule is_ntsmcf_axioms)

mk_ide rf is_ntsmcf_def[unfolded is_ntsmcf_axioms_def]
  |intro is_ntsmcfI|
  |dest is_ntsmcfD[dest]|
  |elim is_ntsmcfE[elim]|

lemmas [smc_cs_intros] = 
  is_ntsmcfD(3,4)

lemma is_ntsmcfI':
  assumes "𝒵 α"
    and "vfsequence 𝔑"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "vcard 𝔑 = 5ℕ"
    and "𝔑⦇NTDom⦈ = 𝔉"
    and "𝔑⦇NTCod⦈ = 𝔊"
    and "𝔑⦇NTDGDom⦈ = 𝔄"
    and "𝔑⦇NTDGCod⦈ = 𝔅"
    and "vsv (𝔑⦇NTMap⦈)"
    and "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
    and "⋀a. a ∈∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈"
  shows "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  by (intro is_ntsmcfI is_tdghmI, unfold ntsmcf_tdghm_components slicing_simps)
    (
      simp_all add: 
        assms nat_omega_simps 
        ntsmcf_tdghm_def  
        is_semifunctorD(6)[OF assms(3)] 
        is_semifunctorD(6)[OF assms(4)]
    )

lemma is_ntsmcfD':
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒵 α"
    and "vfsequence 𝔑"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "vcard 𝔑 = 5ℕ"
    and "𝔑⦇NTDom⦈ = 𝔉"
    and "𝔑⦇NTCod⦈ = 𝔊"
    and "𝔑⦇NTDGDom⦈ = 𝔄"
    and "𝔑⦇NTDGCod⦈ = 𝔅"
    and "vsv (𝔑⦇NTMap⦈)"
    and "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
    and "⋀a. a ∈∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈"
  by 
    (
      simp_all add: 
        is_ntsmcfD(2-11)[OF assms] 
        is_tdghmD[OF is_ntsmcfD(6)[OF assms], unfolded slicing_simps]
    )

lemma is_ntsmcfE':
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  obtains "𝒵 α"
    and "vfsequence 𝔑"
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "vcard 𝔑 = 5ℕ"
    and "𝔑⦇NTDom⦈ = 𝔉"
    and "𝔑⦇NTCod⦈ = 𝔊"
    and "𝔑⦇NTDGDom⦈ = 𝔄"
    and "𝔑⦇NTDGCod⦈ = 𝔅"
    and "vsv (𝔑⦇NTMap⦈)"
    and "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
    and "⋀a. a ∈∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 𝔊⦇ObjMap⦈⦇a⦈"
    and "⋀a b f. f : a ↦𝔄 b ⟹
      𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈"
  using assms by (simp add: is_ntsmcfD')


text‹Slicing.›

context is_ntsmcf
begin

interpretation tdghm: is_tdghm 
  α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉› ‹smcf_dghm 𝔊› ‹ntsmcf_tdghm 𝔑›
  by (rule ntsmcf_is_tdghm)

lemmas_with [unfolded slicing_simps]:
  ntsmcf_NTMap_vsv = tdghm.tdghm_NTMap_vsv
  and ntsmcf_NTMap_vdomain[smc_cs_simps] = tdghm.tdghm_NTMap_vdomain
  and ntsmcf_NTMap_is_arr = tdghm.tdghm_NTMap_is_arr
  and ntsmcf_NTMap_is_arr'[smc_cs_intros]  = tdghm.tdghm_NTMap_is_arr'

sublocale NTMap: vsv ‹𝔑⦇NTMap⦈›
  rewrites "𝒟∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
  by (rule ntsmcf_NTMap_vsv) (simp add: smc_cs_simps)

lemmas_with [unfolded slicing_simps]:
  ntsmcf_NTMap_app_in_Arr[smc_cs_intros] = tdghm.tdghm_NTMap_app_in_Arr
  and ntsmcf_NTMap_vrange_vifunion = tdghm.tdghm_NTMap_vrange_vifunion
  and ntsmcf_NTMap_vrange = tdghm.tdghm_NTMap_vrange
  and ntsmcf_NTMap_vsubset_Vset = tdghm.tdghm_NTMap_vsubset_Vset
  and ntsmcf_NTMap_in_Vset = tdghm.tdghm_NTMap_in_Vset
  and ntsmcf_is_tdghm_if_ge_Limit = tdghm.tdghm_is_tdghm_if_ge_Limit

end

lemmas [smc_cs_intros] = is_ntsmcf.ntsmcf_NTMap_is_arr'

lemma (in is_ntsmcf) ntsmcf_Comp_commute':
  assumes "f : a ↦𝔄 b" and "g : c ↦𝔅 𝔉⦇ObjMap⦈⦇a⦈"
  shows 
    "𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 (𝔉⦇ArrMap⦈⦇f⦈ ∘A𝔅 g) =
      (𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈) ∘A𝔅 g"
  using assms
  by 
    (
      cs_concl 
        cs_simp: ntsmcf_Comp_commute semicategory.smc_Comp_assoc[symmetric] 
        cs_intro: smc_cs_intros
    )

lemma (in is_ntsmcf) ntsmcf_Comp_commute'':
  assumes "f : a ↦𝔄 b" and "g : c ↦𝔅 𝔉⦇ObjMap⦈⦇a⦈"
  shows 
    "𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 (𝔑⦇NTMap⦈⦇a⦈ ∘A𝔅 g) =
      (𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈) ∘A𝔅 g"
  using assms
  by 
    (
      cs_concl 
        cs_simp: ntsmcf_Comp_commute semicategory.smc_Comp_assoc[symmetric] 
        cs_intro: smc_cs_intros
    )


text‹Elementary properties.›

lemma ntsmcf_eqI:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑' : 𝔉' ↦SMCF 𝔊' : 𝔄' ↦↦SMCα 𝔅'"
    and "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
    and "𝔉 = 𝔉'"
    and "𝔊 = 𝔊'"
    and "𝔄 = 𝔄'"
    and "𝔅 = 𝔅'"
  shows "𝔑 = 𝔑'"
proof-
  interpret L: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret R: is_ntsmcf α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
  show ?thesis
  proof(rule vsv_eqI)
    have dom: "𝒟∘ 𝔑 = 5ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
    show "𝒟∘ 𝔑 = 𝒟∘ 𝔑'" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
    from assms(4-7) have sup: 
      "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈" 
      "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈" 
      by (simp_all add: smc_cs_simps)
    show "a ∈∘ 𝒟∘ 𝔑 ⟹ 𝔑⦇a⦈ = 𝔑'⦇a⦈" for a 
      by (unfold dom, elim_in_numeral, insert assms(3) sup)
        (auto simp: nt_field_simps)
  qed auto
qed

lemma ntsmcf_tdghm_eqI:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑' : 𝔉' ↦SMCF 𝔊' : 𝔄' ↦↦SMCα 𝔅'"
    and "𝔉 = 𝔉'"
    and "𝔊 = 𝔊'"
    and "𝔄 = 𝔄'"
    and "𝔅 = 𝔅'"
    and "ntsmcf_tdghm 𝔑 = ntsmcf_tdghm 𝔑'"
  shows "𝔑 = 𝔑'"
proof(rule ntsmcf_eqI[of α])
  from assms(7) have "ntsmcf_tdghm 𝔑⦇NTMap⦈ = ntsmcf_tdghm 𝔑'⦇NTMap⦈" by simp
  then show "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈" unfolding slicing_simps by simp_all
  from assms(3-6) show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by simp_all
qed (simp_all add: assms(1,2))

lemma (in is_ntsmcf) ntsmcf_def:
  "𝔑 = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ 𝔑 = 5ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
  have dom_rhs:
    "𝒟∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈]∘ = 5ℕ"
    by (simp add: nat_omega_simps)
  then show "𝒟∘ 𝔑 = 𝒟∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘"
    unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
  show "a ∈∘ 𝒟∘ 𝔑 ⟹
    𝔑⦇a⦈ = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]∘⦇a⦈" 
    for a
    by (unfold dom_lhs, elim_in_numeral, unfold nt_field_simps)
      (simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)


text‹Size.›

lemma (in is_ntsmcf) ntsmcf_in_Vset: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 ∈∘ Vset β"
proof-
  interpret β: 𝒵 β by (rule assms(1))
  note [smc_cs_intros] = 
    ntsmcf_NTMap_in_Vset
    NTDom.smcf_in_Vset
    NTCod.smcf_in_Vset
    NTDom.HomDom.smc_in_Vset
    NTDom.HomCod.smc_in_Vset
  from assms(2) show ?thesis
    by (subst ntsmcf_def) 
      (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed

lemma (in is_ntsmcf) ntsmcf_is_ntsmcf_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCβ 𝔅"
proof(intro is_ntsmcfI )
  show "ntsmcf_tdghm 𝔑 :
    smcf_dghm 𝔉 ↦DGHM smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DGβ smc_dg 𝔅"
    by (rule is_tdghm.tdghm_is_tdghm_if_ge_Limit[OF ntsmcf_is_tdghm assms])
  show "𝔑⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈"
    if "f : a ↦𝔄 b" for f a b
    using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)+
qed 
  (
    cs_concl 
      cs_simp: smc_cs_simps 
      cs_intro:
        smc_cs_intros
        V_cs_intros
        assms 
        NTDom.smcf_is_semifunctor_if_ge_Limit
        NTCod.smcf_is_semifunctor_if_ge_Limit
   )+

lemma small_all_ntsmcfs[simp]: 
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"
proof(cases ‹𝒵 α›)
  case True
  from is_ntsmcf.ntsmcf_in_Vset show ?thesis
    by (intro down[of _ ‹Vset (α + ω)›]) 
      (auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
  case False
  then have "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅} = {}" by auto
  then show ?thesis by simp
qed

lemma small_ntsmcfs[simp]: "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"
  by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}›])
    auto

lemma small_these_ntcfs[simp]: "small {𝔑. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}"
  by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅}›]) 
    auto


text‹Further elementary results.›

lemma these_ntsmcfs_iff(*not simp*):  
  "𝔑 ∈∘ these_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷ 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  by auto



subsection‹Opposite natural transformation of semifunctors›


subsubsection‹Definition and elementary properties›


text‹See section 1.5 in \cite{bodo_categories_1970}.›

definition op_ntsmcf :: "V ⇒ V"
  where "op_ntsmcf 𝔑 =
    [
      𝔑⦇NTMap⦈,
      op_smcf (𝔑⦇NTCod⦈),
      op_smcf (𝔑⦇NTDom⦈),
      op_smc (𝔑⦇NTDGDom⦈),
      op_smc (𝔑⦇NTDGCod⦈)
    ]∘"


text‹Components.›

lemma op_ntsmcf_components[smc_op_simps]:
  shows "op_ntsmcf 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
    and "op_ntsmcf 𝔑⦇NTDom⦈ = op_smcf (𝔑⦇NTCod⦈)"
    and "op_ntsmcf 𝔑⦇NTCod⦈ = op_smcf (𝔑⦇NTDom⦈)"
    and "op_ntsmcf 𝔑⦇NTDGDom⦈ = op_smc (𝔑⦇NTDGDom⦈)"
    and "op_ntsmcf 𝔑⦇NTDGCod⦈ = op_smc (𝔑⦇NTDGCod⦈)"
  unfolding op_ntsmcf_def nt_field_simps by (auto simp: nat_omega_simps)


text‹Slicing.›

lemma op_tdghm_ntsmcf_tdghm[slicing_commute]: 
  "op_tdghm (ntsmcf_tdghm 𝔑) = ntsmcf_tdghm (op_ntsmcf 𝔑)"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ (op_tdghm (ntsmcf_tdghm 𝔑)) = 5ℕ"
    unfolding op_tdghm_def by (auto simp: nat_omega_simps)
  have dom_rhs: "𝒟∘ (ntsmcf_tdghm (op_ntsmcf 𝔑)) = 5ℕ"
    unfolding ntsmcf_tdghm_def by (auto simp: nat_omega_simps)
  show "𝒟∘ (op_tdghm (ntsmcf_tdghm 𝔑)) = 𝒟∘ (ntsmcf_tdghm (op_ntsmcf 𝔑))"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (op_tdghm (ntsmcf_tdghm 𝔑)) ⟹ 
    op_tdghm (ntsmcf_tdghm 𝔑)⦇a⦈ = ntsmcf_tdghm (op_ntsmcf 𝔑)⦇a⦈"
    for a
    by
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold ntsmcf_tdghm_def op_ntsmcf_def op_tdghm_def nt_field_simps
      )
      (auto simp: nat_omega_simps slicing_commute[symmetric])
qed (auto simp: ntsmcf_tdghm_def op_tdghm_def)


subsubsection‹Further properties›

lemma (in is_ntsmcf) is_ntsmcf_op: 
  "op_ntsmcf 𝔑 : op_smcf 𝔊 ↦SMCF op_smcf 𝔉 : op_smc 𝔄 ↦↦SMCα op_smc 𝔅"
proof(rule is_ntsmcfI, unfold smc_op_simps)
  show "vfsequence (op_ntsmcf 𝔑)" by (simp add: op_ntsmcf_def)
  show "vcard (op_ntsmcf 𝔑) = 5ℕ" by (simp add: op_ntsmcf_def nat_omega_simps)
  fix f a b assume "f : b ↦𝔄 a"
  with is_ntsmcf_axioms show 
    "𝔑⦇NTMap⦈⦇b⦈ ∘Aop_smc 𝔅 𝔊⦇ArrMap⦈⦇f⦈ =
      𝔉⦇ArrMap⦈⦇f⦈ ∘Aop_smc 𝔅 𝔑⦇NTMap⦈⦇a⦈"
    by (cs_concl cs_simp: smc_cs_simps smc_op_simps cs_intro: smc_cs_intros)
qed
  (
    insert is_ntsmcf_axioms,
    (
      cs_concl 
        cs_simp: smc_cs_simps slicing_commute[symmetric]
        cs_intro: smc_cs_intros smc_op_intros dg_op_intros slicing_intros
    )+
  )

lemma (in is_ntsmcf) is_ntsmcf_op'[smc_op_intros]: 
  assumes "𝔊' = op_smcf 𝔊"
    and "𝔉' = op_smcf 𝔉"
    and "𝔄' = op_smc 𝔄"
    and "𝔅' = op_smc 𝔅"
  shows "op_ntsmcf 𝔑 : 𝔊' ↦SMCF 𝔉' : 𝔄' ↦↦SMCα 𝔅'"
  unfolding assms by (rule is_ntsmcf_op)

lemmas [smc_op_intros] = is_ntsmcf.is_ntsmcf_op'

lemma (in is_ntsmcf) ntsmcf_op_ntsmcf_op_ntsmcf[smc_op_simps]: 
  "op_ntsmcf (op_ntsmcf 𝔑) = 𝔑"
proof(rule ntsmcf_eqI[of α 𝔄 𝔅 𝔉 𝔊 _ 𝔄 𝔅 𝔉 𝔊], unfold smc_op_simps)
  interpret op: 
    is_ntsmcf α ‹op_smc 𝔄› ‹op_smc 𝔅› ‹op_smcf 𝔊› ‹op_smcf 𝔉› ‹op_ntsmcf 𝔑›
    by (rule is_ntsmcf_op)
  from op.is_ntsmcf_op show 
    "op_ntsmcf (op_ntsmcf 𝔑) : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    by (simp add: smc_op_simps)
qed (auto simp: smc_cs_intros)

lemmas ntsmcf_op_ntsmcf_op_ntsmcf[smc_op_simps] =
  is_ntsmcf.ntsmcf_op_ntsmcf_op_ntsmcf

lemma eq_op_ntsmcf_iff: 
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑' : 𝔉' ↦SMCF 𝔊' : 𝔄' ↦↦SMCα 𝔅'"
  shows "op_ntsmcf 𝔑 = op_ntsmcf 𝔑' ⟷ 𝔑 = 𝔑'"
proof
  interpret L: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret R: is_ntsmcf α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
  assume prems: "op_ntsmcf 𝔑 = op_ntsmcf 𝔑'"
  show "𝔑 = 𝔑'"
  proof(rule ntsmcf_eqI[OF assms])
    from prems L.ntsmcf_op_ntsmcf_op_ntsmcf R.ntsmcf_op_ntsmcf_op_ntsmcf show 
      "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
      by metis+
    from prems L.ntsmcf_op_ntsmcf_op_ntsmcf R.ntsmcf_op_ntsmcf_op_ntsmcf 
    have "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" 
      and "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈" 
      and "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" 
      and "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈" 
      by metis+
    then show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by (auto simp: smc_cs_simps)
  qed
qed auto



subsection‹Vertical composition of natural transformations›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-4 in \cite{mac_lane_categories_2010}.›

definition ntsmcf_vcomp :: "V ⇒ V ⇒ V" (infixl ‹∙NTSMCF› 55)
  where "ntsmcf_vcomp 𝔐 𝔑 = 
    [
      (λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈. (𝔐⦇NTMap⦈⦇a⦈) ∘A𝔑⦇NTDGCod⦈ (𝔑⦇NTMap⦈⦇a⦈)),
      𝔑⦇NTDom⦈,
      𝔐⦇NTCod⦈,
      𝔑⦇NTDGDom⦈,
      𝔐⦇NTDGCod⦈
    ]∘"


text‹Components.›

lemma ntsmcf_vcomp_components:
  shows
    "(𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈ =
      (λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈. (𝔐⦇NTMap⦈⦇a⦈) ∘A𝔑⦇NTDGCod⦈ (𝔑⦇NTMap⦈⦇a⦈))"
    and [dg_shared_cs_simps, smc_cs_simps]: "(𝔐 ∙NTSMCF 𝔑)⦇NTDom⦈ = 𝔑⦇NTDom⦈" 
    and [dg_shared_cs_simps, smc_cs_simps]: "(𝔐 ∙NTSMCF 𝔑)⦇NTCod⦈ = 𝔐⦇NTCod⦈"
    and [dg_shared_cs_simps, smc_cs_simps]: 
      "(𝔐 ∙NTSMCF 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
    and [dg_shared_cs_simps, smc_cs_simps]: 
      "(𝔐 ∙NTSMCF 𝔑)⦇NTDGCod⦈ = 𝔐⦇NTDGCod⦈"
  unfolding nt_field_simps ntsmcf_vcomp_def by (simp_all add: nat_omega_simps)


subsubsection‹Natural transformation map›

lemma ntsmcf_vcomp_NTMap_vsv[dg_shared_cs_intros, smc_cs_intros]: 
  "vsv ((𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈)"
  unfolding ntsmcf_vcomp_components by simp

lemma ntsmcf_vcomp_NTMap_vdomain[smc_cs_simps]:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms by auto
  show ?thesis unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
qed

lemma ntsmcf_vcomp_NTMap_app[smc_cs_simps]:
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "a ∈∘ 𝔄⦇Obj⦈" 
  shows "(𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ = 𝔐⦇NTMap⦈⦇a⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈"
proof-
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 using assms by auto
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms by auto
  from assms show ?thesis 
    unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
qed

lemma ntsmcf_vcomp_NTMap_vrange:
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈) ⊆∘ 𝔅⦇Arr⦈"
  unfolding ntsmcf_vcomp_components
proof(rule vrange_VLambda_vsubset)
  fix x assume prems: "x ∈∘ 𝔑⦇NTDGDom⦈⦇Obj⦈"
  from prems assms show "𝔐⦇NTMap⦈⦇x⦈ ∘A𝔑⦇NTDGCod⦈ 𝔑⦇NTMap⦈⦇x⦈ ∈∘ 𝔅⦇Arr⦈"
    by (cs_prems cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
      (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed


subsubsection‹Further properties›

lemma ntsmcf_vcomp_composable_commute[smc_cs_simps]:
  ―‹See Chapter II-4 in \cite{mac_lane_categories_2010}).›
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "f : a ↦𝔄 b"
  shows 
    "(𝔐⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇b⦈) ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ = 
      ℌ⦇ArrMap⦈⦇f⦈ ∘A𝔅 (𝔐⦇NTMap⦈⦇a⦈ ∘A𝔅 𝔑⦇NTMap⦈⦇a⦈)"
    (is ‹(?MC ∘A𝔅 ?NC) ∘A𝔅 ?R = ?T ∘A𝔅 (?MD ∘A𝔅 ?ND)›)
proof-
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1)) 
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  from assms show ?thesis
    by (intro 𝔐.NTDom.HomCod.smc_pattern_rectangle_left)
      (cs_concl cs_intro: smc_cs_intros cs_simp: 𝔑.ntsmcf_Comp_commute)
qed 

lemma ntsmcf_vcomp_is_ntsmcf[smc_cs_intros]:
  ―‹See Chapter II-4 in \cite{mac_lane_categories_2010}.›
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝔐 ∙NTSMCF 𝔑 : 𝔉 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅"
proof-
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis 
  proof(intro is_ntsmcfI')
    show "vfsequence (𝔐 ∙NTSMCF 𝔑)" by (simp add: ntsmcf_vcomp_def)
    show "vcard (𝔐 ∙NTSMCF 𝔑) = 5ℕ"
      by (auto simp: nat_omega_simps ntsmcf_vcomp_def)
    show "vsv ((𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈)"
      unfolding ntsmcf_vcomp_components by simp
    from assms show "(𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦𝔅 ℌ⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝔄⦇Obj⦈" for a
      using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    fix f a b assume "f : a ↦𝔄 b"
    with assms show 
      "(𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈⦇b⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇f⦈ =
        ℌ⦇ArrMap⦈⦇f⦈ ∘A𝔅 (𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps is_ntsmcf.ntsmcf_Comp_commute' 
            cs_intro: smc_cs_intros
        )
  qed (use assms in ‹auto simp: smc_cs_simps ntsmcf_vcomp_NTMap_vrange›)
qed

lemma ntsmcf_vcomp_assoc[smc_cs_simps]: 
  ―‹See Chapter II-4 in \cite{mac_lane_categories_2010}.›
  assumes "𝔏 : ℌ ↦SMCF 𝔎 : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "(𝔏 ∙NTSMCF 𝔐) ∙NTSMCF 𝔑 = 𝔏 ∙NTSMCF (𝔐 ∙NTSMCF 𝔑)"
proof-
  interpret 𝔏: is_ntsmcf α 𝔄 𝔅 ℌ 𝔎 𝔏 by (rule assms(1))
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(2))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
  show ?thesis
  proof(rule ntsmcf_eqI[of α])
    show "((𝔏 ∙NTSMCF 𝔐) ∙NTSMCF 𝔑)⦇NTMap⦈ = (𝔏 ∙NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈"
    proof(rule vsv_eqI)
      fix a assume "a ∈∘ 𝒟∘ ((𝔏 ∙NTSMCF 𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈)"
      then have "a ∈∘ 𝔄⦇Obj⦈" 
        unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
      with assms show 
        "((𝔏 ∙NTSMCF 𝔐) ∙NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ =
          (𝔏 ∙NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈⦇a⦈"
        by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    qed (simp_all add: ntsmcf_vcomp_components)
  qed (auto intro: smc_cs_intros)
qed


subsubsection‹
Opposite of the vertical composition of natural transformations
of semifunctors
›

lemma op_ntsmcf_ntsmcf_vcomp[smc_op_simps]: 
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "op_ntsmcf (𝔐 ∙NTSMCF 𝔑) = op_ntsmcf 𝔑 ∙NTSMCF op_ntsmcf 𝔐"
proof-
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 using assms(1) by auto
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms(2) by auto
  show ?thesis
  proof(rule ntsmcf_eqI[of α]; (intro symmetric)?)
    show "op_ntsmcf (𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈ = 
      (op_ntsmcf 𝔑 ∙NTSMCF op_ntsmcf 𝔐)⦇NTMap⦈"
    proof(rule vsv_eqI)
      fix a assume "a ∈∘ 𝒟∘ (op_ntsmcf (𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈)"
      then have a: "a ∈∘ 𝔄⦇Obj⦈"
        unfolding smc_op_simps ntsmcf_vcomp_NTMap_vdomain[OF assms(2)] by simp
      with 
        𝔐.NTDom.HomCod.op_smc_Comp 
        𝔐.ntsmcf_NTMap_is_arr[OF a]
        𝔑.ntsmcf_NTMap_is_arr[OF a] 
      show "op_ntsmcf (𝔐 ∙NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ =
        (op_ntsmcf 𝔑 ∙NTSMCF op_ntsmcf 𝔐)⦇NTMap⦈⦇a⦈"
        unfolding smc_op_simps ntsmcf_vcomp_components 
        by (simp add: smc_cs_simps)
    qed (simp_all add: smc_op_simps smc_cs_simps ntsmcf_vcomp_components(1))
  qed (auto intro: smc_cs_intros smc_op_intros)
qed



subsection‹Horizontal composition of natural transformations›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›

definition ntsmcf_hcomp :: "V ⇒ V ⇒ V" (infixl ‹∘NTSMCF› 55)
  where "ntsmcf_hcomp 𝔐 𝔑 =
    [
      (
        λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈.
          (
            𝔐⦇NTCod⦈⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘A𝔐⦇NTDGCod⦈ 
            𝔐⦇NTMap⦈⦇𝔑⦇NTDom⦈⦇ObjMap⦈⦇a⦈⦈
          )
      ),
      (𝔐⦇NTDom⦈ ∘SMCF 𝔑⦇NTDom⦈),
      (𝔐⦇NTCod⦈ ∘SMCF 𝔑⦇NTCod⦈),
      (𝔑⦇NTDGDom⦈),
      (𝔐⦇NTDGCod⦈)
    ]∘"


text‹Components.›                                            

lemma ntsmcf_hcomp_components:
  shows 
    "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈ = 
      (
        λa∈∘𝔑⦇NTDGDom⦈⦇Obj⦈.
          (
            𝔐⦇NTCod⦈⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘A𝔐⦇NTDGCod⦈ 
            𝔐⦇NTMap⦈⦇𝔑⦇NTDom⦈⦇ObjMap⦈⦇a⦈⦈
          )
      )"
    and [dg_shared_cs_simps, smc_cs_simps]:
      "(𝔐 ∘NTSMCF 𝔑)⦇NTDom⦈ = 𝔐⦇NTDom⦈ ∘SMCF 𝔑⦇NTDom⦈" 
    and [dg_shared_cs_simps, smc_cs_simps]:
      "(𝔐 ∘NTSMCF 𝔑)⦇NTCod⦈ = 𝔐⦇NTCod⦈ ∘SMCF 𝔑⦇NTCod⦈"
    and [dg_shared_cs_simps, smc_cs_simps]: 
      "(𝔐 ∘NTSMCF 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
    and [dg_shared_cs_simps, smc_cs_simps]:
      "(𝔐 ∘NTSMCF 𝔑)⦇NTDGCod⦈ = 𝔐⦇NTDGCod⦈"
  unfolding nt_field_simps ntsmcf_hcomp_def by (auto simp: nat_omega_simps)


subsubsection‹Natural transformation map›

lemma ntsmcf_hcomp_NTMap_vsv[smc_cs_intros]: "vsv ((𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈)"
  unfolding ntsmcf_hcomp_components by auto

lemma ntsmcf_hcomp_NTMap_vdomain[smc_cs_simps]: 
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝒟∘ ((𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
proof-
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  show ?thesis unfolding ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed

lemma ntsmcf_hcomp_NTMap_app[smc_cs_simps]:
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "a ∈∘ 𝔄⦇Obj⦈" 
  shows "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ = 
    𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘Aℭ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  from assms(3) show ?thesis 
    unfolding ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed

lemma ntsmcf_hcomp_NTMap_vrange:
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  fix f assume "f ∈∘ ℛ∘ ((𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈)"
  with ntsmcf_hcomp_NTMap_vdomain obtain a 
    where a: "a ∈∘ 𝔄⦇Obj⦈" and f_def: "f = (𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
    unfolding ntsmcf_hcomp_components by (force simp: smc_cs_simps)
  have 𝔉a: "𝔉⦇ObjMap⦈⦇a⦈ ∈∘ 𝔅⦇Obj⦈" 
    by (simp add: 𝔑.NTDom.smcf_ObjMap_app_in_HomCod_Obj a)
  from 𝔑.ntsmcf_NTMap_is_arr[OF a] have "𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ :
    𝔊'⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈ ↦ℭ 𝔊'⦇ObjMap⦈⦇𝔊⦇ObjMap⦈⦇a⦈⦈"
    by (force intro: smc_cs_intros)
  then have "𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘Aℭ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈ ∈∘ ℭ⦇Arr⦈"
    by 
      (
        meson 
          𝔐.ntsmcf_NTMap_is_arr[OF 𝔉a] 
          𝔐.NTDom.HomCod.smc_is_arrE 
          𝔐.NTDom.HomCod.smc_Comp_is_arr
      )
  with a show "f ∈∘ ℭ⦇Arr⦈" 
    unfolding f_def ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed


subsubsection‹Further properties›

lemma ntsmcf_hcomp_composable_commute:
  ―‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "f : a ↦𝔄 b" 
  shows 
    "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇b⦈ ∘Aℭ (𝔉' ∘SMCF 𝔉)⦇ArrMap⦈⦇f⦈ = 
      (𝔊' ∘SMCF 𝔊)⦇ArrMap⦈⦇f⦈ ∘Aℭ (𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
proof-
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  from assms(3) have [simp]: "b ∈∘ 𝔄⦇Obj⦈" and a: "a ∈∘ 𝔄⦇Obj⦈" by auto
  from 𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have 𝔐𝔑b: 
    "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇b⦈ =
      (𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇b⦈⦈) ∘Aℭ (𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇b⦈⦈)"
    by (auto simp: smc_cs_simps)
  let ?𝔊'𝔉f = ‹𝔊'⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈›
  from a 𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have 𝔐𝔑a: 
    "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ =
      𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘Aℭ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
    by (cs_concl cs_simp: smc_cs_simps)+
  note 𝔐.NTCod.smcf_ArrMap_Comp[smc_cs_simps del]
  from assms show ?thesis
    unfolding 𝔐𝔑b 𝔐𝔑a 
    by (intro 𝔐.NTDom.HomCod.smc_pattern_rectangle_left)
      (
        cs_concl 
          cs_simp: smc_cs_simps is_semifunctor.smcf_ArrMap_Comp[symmetric] 
          cs_intro: smc_cs_intros
      )+
qed

lemma ntsmcf_hcomp_is_ntsmcf:
  ―‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "𝔐 ∘NTSMCF 𝔑 : 𝔉' ∘SMCF 𝔉 ↦SMCF 𝔊' ∘SMCF 𝔊 : 𝔄 ↦↦SMCα ℭ"
proof-
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis
  proof(intro is_ntsmcfI', unfold ntsmcf_hcomp_components(3,4)) 
    show "vfsequence (𝔐 ∘NTSMCF 𝔑)" unfolding ntsmcf_hcomp_def by auto
    show "vcard (𝔐 ∘NTSMCF 𝔑) = 5ℕ"
      unfolding ntsmcf_hcomp_def by (simp add: nat_omega_simps)
    from assms show "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ : 
      (𝔉' ∘SMCF 𝔉)⦇ObjMap⦈⦇a⦈ ↦ℭ (𝔊' ∘SMCF 𝔊)⦇ObjMap⦈⦇a⦈"
      if "a ∈∘ 𝔄⦇Obj⦈" for a
      using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    fix f a b assume "f : a ↦𝔄 b"
    with ntsmcf_hcomp_composable_commute[OF assms] 
    show "(𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇b⦈ ∘Aℭ (𝔉' ∘SMCF 𝔉)⦇ArrMap⦈⦇f⦈ = 
      (𝔊' ∘SMCF 𝔊)⦇ArrMap⦈⦇f⦈ ∘Aℭ (𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
      by auto
  qed (auto simp: ntsmcf_hcomp_components(1) smc_cs_simps intro: smc_cs_intros)
qed

lemma ntsmcf_hcomp_is_ntsmcf'[smc_cs_intros]:
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔖 = 𝔉' ∘SMCF 𝔉"
    and "𝔖' = 𝔊' ∘SMCF 𝔊"
  shows "𝔐 ∘NTSMCF 𝔑 : 𝔖 ↦SMCF 𝔖' : 𝔄 ↦↦SMCα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule ntsmcf_hcomp_is_ntsmcf)

lemma ntsmcf_hcomp_assoc[smc_cs_simps]: 
  ―‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›
  assumes "𝔏 : 𝔉'' ↦SMCF 𝔊'' : ℭ ↦↦SMCα 𝔇" 
    and "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "(𝔏 ∘NTSMCF 𝔐) ∘NTSMCF 𝔑 = 𝔏 ∘NTSMCF (𝔐 ∘NTSMCF 𝔑)"
proof-
  interpret 𝔏: is_ntsmcf α ℭ 𝔇 𝔉'' 𝔊'' 𝔏 by (rule assms(1))
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐  by (rule assms(2))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
  interpret 𝔏𝔐: is_ntsmcf α 𝔅 𝔇 ‹𝔉'' ∘SMCF 𝔉'› ‹𝔊'' ∘SMCF 𝔊'› ‹𝔏 ∘NTSMCF 𝔐› 
    by (auto intro: smc_cs_intros)
  interpret 𝔐𝔑: is_ntsmcf α 𝔄 ℭ ‹𝔉' ∘SMCF 𝔉› ‹𝔊' ∘SMCF 𝔊› ‹𝔐 ∘NTSMCF 𝔑› 
    by (auto intro: smc_cs_intros)
  note smcf_axioms =
    𝔏.NTDom.is_semifunctor_axioms 
    𝔏.NTCod.is_semifunctor_axioms 
    𝔐.NTDom.is_semifunctor_axioms 
    𝔐.NTCod.is_semifunctor_axioms 
    𝔑.NTDom.is_semifunctor_axioms 
    𝔑.NTCod.is_semifunctor_axioms 
  show ?thesis
  proof(rule ntsmcf_eqI)
    from assms show 
      "𝔏 ∘NTSMCF 𝔐 ∘NTSMCF 𝔑 :
        (𝔉'' ∘SMCF 𝔉') ∘SMCF 𝔉 ↦SMCF (𝔊'' ∘SMCF 𝔊') ∘SMCF 𝔊 :
        𝔄 ↦↦SMCα 𝔇"
      by (auto intro: smc_cs_intros)
    from 𝔏𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have dom_lhs:
      "𝒟∘ ((𝔏 ∘NTSMCF 𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (simp add: smc_cs_simps)
    from 𝔐𝔑.is_ntsmcf_axioms 𝔏.is_ntsmcf_axioms have dom_rhs:  
      "𝒟∘ ((𝔏 ∘NTSMCF (𝔐 ∘NTSMCF 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
      by (simp add: smc_cs_simps)
    show "(𝔏 ∘NTSMCF 𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈ = (𝔏 ∘NTSMCF (𝔐 ∘NTSMCF 𝔑))⦇NTMap⦈"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      with assms show
        "(𝔏 ∘NTSMCF 𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈ =
          (𝔏 ∘NTSMCF (𝔐 ∘NTSMCF 𝔑))⦇NTMap⦈⦇a⦈"
        by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    qed (simp_all add: ntsmcf_hcomp_components)
  qed 
    (
      insert smcf_axioms, 
      auto simp: smcf_comp_assoc intro!: smc_cs_intros
    )
qed


subsubsection‹Opposite of the horizontal composition of the 
natural transformation of semifunctors›

lemma op_ntsmcf_ntsmcf_hcomp[smc_op_simps]: 
  assumes "𝔐 : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "op_ntsmcf (𝔐 ∘NTSMCF 𝔑) = op_ntsmcf 𝔐 ∘NTSMCF op_ntsmcf 𝔑"
proof-
  interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  have op_𝔐: "op_ntsmcf 𝔐 :
    op_smcf 𝔊' ↦SMCF op_smcf 𝔉' : op_smc 𝔅 ↦↦SMCα op_smc ℭ"
    and op_𝔑: "op_ntsmcf 𝔑 :
    op_smcf 𝔊 ↦SMCF op_smcf 𝔉 : op_smc 𝔄 ↦↦SMCα op_smc 𝔅" 
    by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
  show ?thesis
  proof(rule sym, rule ntsmcf_eqI, unfold smc_op_simps slicing_simps)
    show 
      "op_ntsmcf 𝔐 ∘NTSMCF op_ntsmcf 𝔑 :
        op_smcf 𝔊' ∘SMCF op_smcf 𝔊 ↦SMCF op_smcf 𝔉' ∘SMCF op_smcf 𝔉 :
        op_smc 𝔄 ↦↦SMCα op_smc ℭ"
      by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
    show "op_ntsmcf (𝔐 ∘NTSMCF 𝔑) :
      op_smcf 𝔊' ∘SMCF op_smcf 𝔊 ↦SMCF op_smcf 𝔉' ∘SMCF op_smcf 𝔉 :
      op_smc 𝔄 ↦↦SMCα op_smc ℭ"
      by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
    show "(op_ntsmcf 𝔐 ∘NTSMCF op_ntsmcf 𝔑)⦇NTMap⦈ = (𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈"
    proof
      (
        rule vsv_eqI, 
        unfold 
          ntsmcf_hcomp_NTMap_vdomain[OF assms(2)]
          ntsmcf_hcomp_NTMap_vdomain[OF op_𝔑]
          smc_op_simps
      )
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      with assms show 
        "(op_ntsmcf 𝔐 ∘NTSMCF op_ntsmcf 𝔑)⦇NTMap⦈⦇a⦈ = (𝔐 ∘NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
        by 
          (
            cs_concl 
              cs_simp: smc_cs_simps smc_op_simps 
              cs_intro: smc_cs_intros smc_op_intros
          )
    qed (auto simp: ntsmcf_hcomp_components)
  qed simp_all
qed 



subsection‹Interchange law›

lemma ntsmcf_comp_interchange_law:
  ―‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›
  assumes "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔐' : 𝔊' ↦SMCF ℌ' : 𝔅 ↦↦SMCα ℭ"
    and "𝔑' : 𝔉' ↦SMCF 𝔊' : 𝔅 ↦↦SMCα ℭ"
  shows 
    "((𝔐' ∙NTSMCF 𝔑') ∘NTSMCF (𝔐 ∙NTSMCF 𝔑)) =
      (𝔐' ∘NTSMCF 𝔐) ∙NTSMCF (𝔑' ∘NTSMCF 𝔑)"
proof-
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  interpret 𝔐': is_ntsmcf α 𝔅 ℭ 𝔊' ℌ' 𝔐' by (rule assms(3))
  interpret 𝔑': is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔑' by (rule assms(4))
  interpret 𝔑'𝔑: 
    is_ntsmcf α 𝔄 ℭ ‹𝔉' ∘SMCF 𝔉› ‹𝔊' ∘SMCF 𝔊› ‹𝔑' ∘NTSMCF 𝔑› 
    by (auto intro: smc_cs_intros)
  interpret 𝔐𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 ℌ ‹𝔐 ∙NTSMCF 𝔑› 
    by (auto intro: smc_cs_intros)
  show ?thesis
  proof(rule ntsmcf_eqI[of α])
    show 
      "(𝔐' ∙NTSMCF 𝔑' ∘NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈ =
        (𝔐' ∘NTSMCF 𝔐 ∙NTSMCF (𝔑' ∘NTSMCF 𝔑))⦇NTMap⦈"
    proof
      (
        rule vsv_eqI,
        unfold 
          ntsmcf_vcomp_NTMap_vdomain[OF 𝔑'𝔑.is_ntsmcf_axioms]
          ntsmcf_hcomp_NTMap_vdomain[OF 𝔐𝔑.is_ntsmcf_axioms]
      )
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      with assms show
        "(𝔐' ∙NTSMCF 𝔑' ∘NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈⦇a⦈ =
          ((𝔐' ∘NTSMCF 𝔐) ∙NTSMCF (𝔑' ∘NTSMCF 𝔑))⦇NTMap⦈⦇a⦈"
        by
          (
            cs_concl
              cs_simp: smc_cs_simps is_ntsmcf.ntsmcf_Comp_commute' 
              cs_intro: smc_cs_intros
          )
    qed (auto intro: smc_cs_intros)
  qed (auto intro: smc_cs_intros)
qed



subsection‹
Composition of a natural transformation of semifunctors and a semifunctor
›


subsubsection‹Definition and elementary properties›

abbreviation (input) ntsmcf_smcf_comp :: "V ⇒ V ⇒ V" (infixl "∘NTSMCF-SMCF" 55)
  where "ntsmcf_smcf_comp ≡ tdghm_dghm_comp"


text‹Slicing.›

lemma ntsmcf_tdghm_ntsmcf_smcf_comp[slicing_commute]: 
  "ntsmcf_tdghm 𝔑 ∘TDGHM-DGHM smcf_dghm ℌ = ntsmcf_tdghm (𝔑 ∘NTSMCF-SMCF ℌ)"
  unfolding 
    tdghm_dghm_comp_def 
    dghm_comp_def 
    ntsmcf_tdghm_def 
    smcf_dghm_def 
    smc_dg_def
    dg_field_simps
    dghm_field_simps 
    nt_field_simps 
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹Natural transformation map›

mk_VLambda (in is_semifunctor) 
  tdghm_dghm_comp_components(1)[where ℌ=𝔉, unfolded smcf_HomDom]
  |vdomain ntsmcf_smcf_comp_NTMap_vdomain[smc_cs_simps]|
  |app ntsmcf_smcf_comp_NTMap_app[smc_cs_simps]|

lemmas [smc_cs_simps] = 
  is_semifunctor.ntsmcf_smcf_comp_NTMap_vdomain
  is_semifunctor.ntsmcf_smcf_comp_NTMap_app

lemma ntsmcf_smcf_comp_NTMap_vrange: 
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔅 ↦↦SMCα ℭ" and "ℌ : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((𝔑 ∘NTSMCF-SMCF ℌ)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
  show ?thesis 
    unfolding tdghm_dghm_comp_components 
    by (auto simp: smc_cs_simps intro: smc_cs_intros)
qed


subsubsection‹
Opposite of the composition of a natural transformation of 
semifunctors and a semifunctor
›

lemma op_ntsmcf_ntsmcf_smcf_comp[smc_op_simps]: 
  "op_ntsmcf (𝔑 ∘NTSMCF-SMCF ℌ) = op_ntsmcf 𝔑 ∘NTSMCF-SMCF op_smcf ℌ"
  unfolding 
    tdghm_dghm_comp_def 
    dghm_comp_def 
    op_ntsmcf_def 
    op_smcf_def 
    op_smc_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹
Composition of a natural transformation of semifunctors and a 
semifunctors is a natural transformation of semifunctors
›

lemma ntsmcf_smcf_comp_is_ntsmcf[intro]:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔅 ↦↦SMCα ℭ" and "ℌ : 𝔄 ↦↦SMCα 𝔅"
  shows "𝔑 ∘NTSMCF-SMCF ℌ : 𝔉 ∘SMCF ℌ ↦SMCF 𝔊 ∘SMCF ℌ : 𝔄 ↦↦SMCα ℭ"
proof-
  interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
  show ?thesis
  proof(rule is_ntsmcfI)
    show "vfsequence (𝔑 ∘NTSMCF-SMCF ℌ)"
      unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
    from assms show "𝔉 ∘SMCF ℌ : 𝔄 ↦↦SMCα ℭ"
      by (cs_concl cs_intro: smc_cs_intros)
    from assms show "𝔊 ∘SMCF ℌ : 𝔄 ↦↦SMCα ℭ" 
      by (cs_concl cs_intro: smc_cs_intros)
    show "vcard (𝔑 ∘NTSMCF-SMCF ℌ) = 5ℕ"
      unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
    from assms show 
      "ntsmcf_tdghm (𝔑 ∘NTSMCF-SMCF ℌ) :
        smcf_dghm (𝔉 ∘SMCF ℌ) ↦DGHM smcf_dghm (𝔊 ∘SMCF ℌ) :
        smc_dg 𝔄 ↦↦DGα smc_dg ℭ"
      by 
        (
          cs_concl 
            cs_simp: slicing_commute[symmetric] 
            cs_intro: slicing_intros dg_cs_intros
        )
    show 
      "(𝔑 ∘NTSMCF-SMCF ℌ)⦇NTMap⦈⦇b⦈ ∘Aℭ (𝔉 ∘SMCF ℌ)⦇ArrMap⦈⦇f⦈ =
        (𝔊 ∘SMCF ℌ)⦇ArrMap⦈⦇f⦈ ∘Aℭ (𝔑 ∘NTSMCF-SMCF ℌ)⦇NTMap⦈⦇a⦈"
      if "f : a ↦𝔄 b" for a b f
      using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  qed (auto simp: smc_cs_simps)
qed

lemma ntsmcf_smcf_comp_is_semifunctor'[smc_cs_intros]:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔅 ↦↦SMCα ℭ" 
    and "ℌ : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉' = 𝔉 ∘SMCF ℌ"
    and "𝔊' = 𝔊 ∘SMCF ℌ"
  shows "𝔑 ∘NTSMCF-SMCF ℌ : 𝔉' ↦SMCF 𝔊' : 𝔄 ↦↦SMCα ℭ"
  using assms(1,2) unfolding assms(3,4) ..


subsubsection‹Further properties›

lemma ntsmcf_smcf_comp_ntsmcf_smcf_comp_assoc:
  assumes "𝔑 : ℌ ↦SMCF ℌ' : ℭ ↦↦SMCα 𝔇" 
    and "𝔊 : 𝔅 ↦↦SMCα ℭ" 
    and "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  shows "(𝔑 ∘NTSMCF-SMCF 𝔊) ∘NTSMCF-SMCF 𝔉 = 𝔑 ∘NTSMCF-SMCF (𝔊 ∘SMCF 𝔉)"
proof-
  interpret 𝔑: is_ntsmcf α ℭ 𝔇 ℌ ℌ' 𝔑 by (rule assms(1))
  interpret 𝔊: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(2))
  interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(3))
  show ?thesis  
  proof(rule ntsmcf_tdghm_eqI)
    from assms show 
      "(𝔑 ∘NTSMCF-SMCF 𝔊) ∘NTSMCF-SMCF 𝔉 :
        ℌ ∘SMCF 𝔊 ∘SMCF 𝔉 ↦SMCF ℌ' ∘SMCF 𝔊 ∘SMCF 𝔉 :
        𝔄 ↦↦SMCα 𝔇"
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    show "𝔑 ∘NTSMCF-SMCF (𝔊 ∘SMCF 𝔉) :
      ℌ ∘SMCF 𝔊 ∘SMCF 𝔉 ↦SMCF ℌ' ∘SMCF 𝔊 ∘SMCF 𝔉 :
      𝔄 ↦↦SMCα 𝔇"
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    from assms show 
      "ntsmcf_tdghm ((𝔑 ∘NTSMCF-SMCF 𝔊) ∘NTSMCF-SMCF 𝔉) =
        ntsmcf_tdghm (𝔑 ∘NTSMCF-SMCF (𝔊 ∘SMCF 𝔉))"
      by 
        (
          cs_concl
            cs_simp: slicing_commute[symmetric] 
            cs_intro: slicing_intros tdghm_dghm_comp_tdghm_dghm_comp_assoc
        )
  qed simp_all
qed

lemma (in is_ntsmcf) ntsmcf_ntsmcf_smcf_comp_smcf_id[smc_cs_simps]:
  "𝔑 ∘NTSMCF-SMCF smcf_id 𝔄 = 𝔑"
proof(rule ntsmcf_tdghm_eqI)
  show "𝔑 ∘NTSMCF-SMCF smcf_id 𝔄 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  show "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  show "ntsmcf_tdghm (𝔑 ∘NTSMCF-SMCF smcf_id 𝔄) = ntsmcf_tdghm 𝔑"
    by 
      (
        cs_concl
          cs_simp: slicing_simps slicing_commute[symmetric] 
          cs_intro: smc_cs_intros slicing_intros dg_cs_simps
      )
qed simp_all

lemmas [smc_cs_simps] = is_ntsmcf.ntsmcf_ntsmcf_smcf_comp_smcf_id

lemma ntsmcf_vcomp_ntsmcf_smcf_comp[smc_cs_simps]:
  assumes "𝔎 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔐 : 𝔊 ↦SMCF ℌ : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔅 ↦↦SMCα ℭ"
  shows 
    "(𝔐 ∘NTSMCF-SMCF 𝔎) ∙NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎) = 
      (𝔐 ∙NTSMCF 𝔑) ∘NTSMCF-SMCF 𝔎"
proof(rule ntsmcf_eqI)
  from assms show "(𝔐 ∙NTSMCF 𝔑) ∘NTSMCF-SMCF 𝔎 : 
    𝔉 ∘SMCF 𝔎 ↦SMCF ℌ ∘SMCF 𝔎 : 𝔄 ↦↦SMCα ℭ"
    by (cs_concl cs_intro: smc_cs_intros)
  from assms show "𝔐 ∘NTSMCF-SMCF 𝔎 ∙NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎) : 
    𝔉 ∘SMCF 𝔎 ↦SMCF ℌ ∘SMCF 𝔎 : 𝔄 ↦↦SMCα ℭ"
    by (cs_concl cs_intro: smc_cs_intros)
  from assms have dom_lhs: 
    "𝒟∘ ((𝔐 ∘NTSMCF-SMCF 𝔎 ∙NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎))⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  from assms have dom_rhs: "𝒟∘ ((𝔐 ∙NTSMCF 𝔑 ∘NTSMCF-SMCF 𝔎)⦇NTMap⦈) = 𝔄⦇Obj⦈"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  show 
    "(𝔐 ∘NTSMCF-SMCF 𝔎 ∙NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎))⦇NTMap⦈ = 
      (𝔐 ∙NTSMCF 𝔑 ∘NTSMCF-SMCF 𝔎)⦇NTMap⦈"
  proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
    fix a assume "a ∈∘ 𝔄⦇Obj⦈"
    with assms show 
      "(𝔐 ∘NTSMCF-SMCF 𝔎 ∙NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎))⦇NTMap⦈⦇a⦈ =
        (𝔐 ∙NTSMCF 𝔑 ∘NTSMCF-SMCF 𝔎)⦇NTMap⦈⦇a⦈"
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  qed (cs_concl cs_intro: smc_cs_intros)+
qed simp_all



subsection‹
Composition of a semifunctor and a natural transformation of semifunctors
›


subsubsection‹Definition and elementary properties›

abbreviation (input) smcf_ntsmcf_comp :: "V ⇒ V ⇒ V" (infixl "∘SMCF-NTSMCF" 55)
  where "smcf_ntsmcf_comp ≡ dghm_tdghm_comp"


text‹Slicing.›

lemma ntsmcf_tdghm_smcf_ntsmcf_comp[slicing_commute]: 
  "smcf_dghm ℌ ∘DGHM-TDGHM ntsmcf_tdghm 𝔑 = ntsmcf_tdghm (ℌ ∘SMCF-NTSMCF 𝔑)"
  unfolding 
    dghm_tdghm_comp_def 
    dghm_comp_def 
    ntsmcf_tdghm_def 
    smcf_dghm_def 
    smc_dg_def
    dg_field_simps
    dghm_field_simps 
    nt_field_simps 
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹Natural transformation map›

mk_VLambda (in is_ntsmcf) 
  dghm_tdghm_comp_components(1)[where 𝔑=𝔑, unfolded ntsmcf_NTDGDom]
  |vdomain smcf_ntsmcf_comp_NTMap_vdomain[smc_cs_simps]|
  |app smcf_ntsmcf_comp_NTMap_app[smc_cs_simps]|

lemmas [smc_cs_simps] = 
  is_ntsmcf.smcf_ntsmcf_comp_NTMap_vdomain
  is_ntsmcf.smcf_ntsmcf_comp_NTMap_app

lemma smcf_ntsmcf_comp_NTMap_vrange: 
  assumes "ℌ : 𝔅 ↦↦SMCα ℭ" and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℛ∘ ((ℌ ∘SMCF-NTSMCF 𝔑)⦇NTMap⦈) ⊆∘ ℭ⦇Arr⦈"
proof-
  interpret ℌ: is_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis 
    unfolding dghm_tdghm_comp_components 
    by (auto simp: smc_cs_simps intro: smc_cs_intros)
qed


subsubsection‹
Opposite of the composition of a semifunctor
and a natural transformation of semifunctors 
›

lemma op_ntsmcf_smcf_ntsmcf_comp[smc_op_simps]: 
  "op_ntsmcf (ℌ ∘SMCF-NTSMCF 𝔑) = op_smcf ℌ ∘SMCF-NTSMCF op_ntsmcf 𝔑"
  unfolding 
    dghm_tdghm_comp_def
    dghm_comp_def
    op_ntsmcf_def
    op_smcf_def
    op_smc_def
    dg_field_simps
    dghm_field_simps
    nt_field_simps
  by (simp add: nat_omega_simps) (*slow*)


subsubsection‹
Composition of a semifunctor and a natural transformation of
semifunctors is a natural transformation of semifunctors
›

lemma smcf_ntsmcf_comp_is_ntsmcf[intro]:
  assumes "ℌ : 𝔅 ↦↦SMCα ℭ" and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows "ℌ ∘SMCF-NTSMCF 𝔑 : ℌ ∘SMCF 𝔉 ↦SMCF ℌ ∘SMCF 𝔊 : 𝔄 ↦↦SMCα ℭ"
proof-
  interpret ℌ: is_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis
  proof(rule is_ntsmcfI)
    show "vfsequence (ℌ ∘SMCF-NTSMCF 𝔑)" unfolding dghm_tdghm_comp_def by simp
    from assms show "ℌ ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ"
      by (cs_concl cs_intro: smc_cs_intros)
    from assms show "ℌ ∘SMCF 𝔊 : 𝔄 ↦↦SMCα ℭ"
      by (cs_concl cs_intro: smc_cs_intros)
    show "vcard (ℌ ∘SMCF-NTSMCF 𝔑) = 5ℕ"
      unfolding dghm_tdghm_comp_def by (simp add: nat_omega_simps)
    from assms show "ntsmcf_tdghm (ℌ ∘SMCF-NTSMCF 𝔑) :
      smcf_dghm (ℌ ∘SMCF 𝔉) ↦DGHM smcf_dghm (ℌ ∘SMCF 𝔊) :
      smc_dg 𝔄 ↦↦DGα smc_dg ℭ"
      by 
        (
          cs_concl 
            cs_simp: slicing_commute[symmetric]  
            cs_intro: dg_cs_intros slicing_intros
        )
    have [smc_cs_simps]:  
      "ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇b⦈⦈ ∘Aℭ ℌ⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈ =
        ℌ⦇ArrMap⦈⦇𝔊⦇ArrMap⦈⦇f⦈⦈ ∘Aℭ ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈"
      if "f : a ↦𝔄 b" for a b f
      using assms that 
      by 
        (
          cs_concl 
            cs_simp:
              is_ntsmcf.ntsmcf_Comp_commute 
              is_semifunctor.smcf_ArrMap_Comp[symmetric]
            cs_intro: smc_cs_intros
        )
    from assms show 
      "(ℌ ∘SMCF-NTSMCF 𝔑)⦇NTMap⦈⦇b⦈ ∘Aℭ (ℌ ∘SMCF 𝔉)⦇ArrMap⦈⦇f⦈ =
        (ℌ ∘SMCF 𝔊)⦇ArrMap⦈⦇f⦈ ∘Aℭ (ℌ ∘SMCF-NTSMCF 𝔑)⦇NTMap⦈⦇a⦈"
      if "f : a ↦𝔄 b" for a b f
      using assms that
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  qed (auto simp: smc_cs_simps)
qed

lemma smcf_ntsmcf_comp_is_semifunctor'[smc_cs_intros]:
  assumes "ℌ : 𝔅 ↦↦SMCα ℭ"
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉' = ℌ ∘SMCF 𝔉"
    and "𝔊' = ℌ ∘SMCF 𝔊"
  shows "ℌ ∘SMCF-NTSMCF 𝔑 : 𝔉' ↦SMCF 𝔊' : 𝔄 ↦↦SMCα ℭ"
  using assms(1,2) unfolding assms(3,4) ..


subsubsection‹Further properties›

lemma smcf_comp_smcf_ntsmcf_comp_assoc:
  assumes "𝔑 : ℌ ↦SMCF ℌ' : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔅 ↦↦SMCα ℭ"
    and "𝔊 : ℭ ↦↦SMCα 𝔇"
  shows "(𝔊 ∘SMCF 𝔉) ∘SMCF-NTSMCF 𝔑 = 𝔊 ∘SMCF-NTSMCF (𝔉 ∘SMCF-NTSMCF 𝔑)"
proof(rule ntsmcf_tdghm_eqI)
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 ℌ ℌ' 𝔑 by (rule assms(1))
  interpret 𝔉: is_semifunctor α 𝔅 ℭ 𝔉 by (rule assms(2))
  interpret 𝔊: is_semifunctor α ℭ 𝔇 𝔊 by (rule assms(3))
  from assms show "(𝔊 ∘SMCF 𝔉) ∘SMCF-NTSMCF 𝔑 :
    𝔊 ∘SMCF 𝔉 ∘SMCF ℌ ↦SMCF 𝔊 ∘SMCF 𝔉 ∘SMCF ℌ' : 𝔄 ↦↦SMCα 𝔇"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  from assms show "𝔊 ∘SMCF-NTSMCF (𝔉 ∘SMCF-NTSMCF 𝔑) :
    𝔊 ∘SMCF 𝔉 ∘SMCF ℌ ↦SMCF 𝔊 ∘SMCF 𝔉 ∘SMCF ℌ' : 𝔄 ↦↦SMCα 𝔇"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  from assms show 
    "ntsmcf_tdghm (𝔊 ∘SMCF 𝔉 ∘SMCF-NTSMCF 𝔑) =
      ntsmcf_tdghm (𝔊 ∘SMCF-NTSMCF (𝔉 ∘SMCF-NTSMCF 𝔑))"
    by
      (
        cs_concl
          cs_simp: slicing_commute[symmetric] 
          cs_intro: slicing_intros dghm_comp_dghm_tdghm_comp_assoc
      )
qed simp_all

lemma (in is_ntsmcf) ntsmcf_smcf_ntsmcf_comp_smcf_id[smc_cs_simps]:
  "smcf_id 𝔅 ∘SMCF-NTSMCF 𝔑 = 𝔑"
proof(rule ntsmcf_tdghm_eqI)
  show "smcf_id 𝔅 ∘SMCF-NTSMCF 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  show "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
  show "ntsmcf_tdghm (dghm_id 𝔅 ∘DGHM-TDGHM 𝔑) = ntsmcf_tdghm 𝔑"
    by 
      (
        cs_concl
          cs_simp: slicing_simps slicing_commute[symmetric] 
          cs_intro: smc_cs_intros slicing_intros dg_cs_simps
      )
qed simp_all

lemmas [smc_cs_simps] = is_ntsmcf.ntsmcf_smcf_ntsmcf_comp_smcf_id

lemma smcf_ntsmcf_comp_ntsmcf_smcf_comp_assoc:
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔅 ↦↦SMCα ℭ"
    and "ℌ : ℭ ↦↦SMCα 𝔇"
    and "𝔎 : 𝔄 ↦↦SMCα 𝔅"
  shows "(ℌ ∘SMCF-NTSMCF 𝔑) ∘NTSMCF-SMCF 𝔎 = ℌ ∘SMCF-NTSMCF (𝔑 ∘NTSMCF-SMCF 𝔎)"
proof-
  interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_semifunctor α ℭ 𝔇 ℌ by (rule assms(2))
  interpret 𝔎: is_semifunctor α 𝔄 𝔅 𝔎 by (rule assms(3))
  show ?thesis
    by (rule ntsmcf_tdghm_eqI)
      (
        use assms in
          ‹
            cs_concl
              cs_simp: smc_cs_simps slicing_commute[symmetric]
              cs_intro:
                smc_cs_intros
                slicing_intros
                dghm_tdghm_comp_tdghm_dghm_comp_assoc
          ›
      )+
qed

lemma smcf_ntsmcf_comp_ntsmcf_vcomp: 
  assumes "𝔎 : 𝔅 ↦↦SMCα ℭ"
    and "𝔐 : 𝔊 ↦SMCF ℌ : 𝔄 ↦↦SMCα 𝔅" 
    and "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
  shows 
    "𝔎 ∘SMCF-NTSMCF (𝔐 ∙NTSMCF 𝔑) =
      (𝔎 ∘SMCF-NTSMCF 𝔐) ∙NTSMCF (𝔎 ∘SMCF-NTSMCF 𝔑)"
proof-
  interpret 𝔎: is_semifunctor α 𝔅 ℭ 𝔎 by (rule assms(1))
  interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(2))
  interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
  show 
    "𝔎 ∘SMCF-NTSMCF (𝔐 ∙NTSMCF 𝔑) = 𝔎 ∘SMCF-NTSMCF 𝔐 ∙NTSMCF (𝔎 ∘SMCF-NTSMCF 𝔑)"
  proof(rule ntsmcf_eqI)
    have dom_lhs: "𝒟∘ ((𝔎 ∘SMCF-NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
      unfolding dghm_tdghm_comp_components smc_cs_simps by simp
    have dom_rhs: 
      "𝒟∘ ((𝔎 ∘SMCF-NTSMCF 𝔐 ∙NTSMCF (𝔎 ∘SMCF-NTSMCF 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
      unfolding ntsmcf_vcomp_components smc_cs_simps by simp
    show
      "(𝔎 ∘SMCF-NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈ =
        (𝔎 ∘SMCF-NTSMCF 𝔐 ∙NTSMCF (𝔎 ∘SMCF-NTSMCF 𝔑))⦇NTMap⦈"
    proof(rule vsv_eqI, unfold dom_lhs dom_rhs smc_cs_simps)
      fix a assume "a ∈∘ 𝔄⦇Obj⦈"
      then show 
        "(𝔎 ∘SMCF-NTSMCF (𝔐 ∙NTSMCF 𝔑))⦇NTMap⦈⦇a⦈ =
          (𝔎 ∘SMCF-NTSMCF 𝔐 ∙NTSMCF (𝔎 ∘SMCF-NTSMCF 𝔑))⦇NTMap⦈⦇a⦈"
        by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
    qed (cs_concl cs_intro: smc_cs_intros)+
  qed (cs_concl cs_intro: smc_cs_intros)+
qed

text‹\newpage›

end

Theory CZH_SMC_Small_NTSMCF

(* Copyright 2021 (C) Mihails Milehins *)

section‹Smallness for natural transformations of semifunctors›
theory CZH_SMC_Small_NTSMCF
  imports 
    CZH_DG_Small_TDGHM
    CZH_SMC_Small_Semifunctor
    CZH_SMC_NTSMCF
begin



subsection‹Natural transformation of semifunctors with tiny maps›


subsubsection‹Definition and elementary properties›

locale is_tm_ntsmcf = is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
  assumes tm_ntsmcf_is_tm_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
    smcf_dghm 𝔉 ↦DGHM.tm smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DG.tmα smc_dg 𝔅"

syntax "_is_tm_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦SMCF.tm _ :/ _ ↦↦SMC.tmı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅" ⇌
  "CONST is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_tm_ntsmcfs :: "V ⇒ V"
  where "all_tm_ntsmcfs α ≡
    set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"

abbreviation tm_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "tm_ntsmcfs α 𝔄 𝔅 ≡
    set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"

abbreviation these_tm_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_tm_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡
    set {𝔑. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"

lemma (in is_tm_ntsmcf) tm_ntsmcf_is_tm_tdghm':
  assumes "α' = α"
    and "𝔉' = smcf_dghm 𝔉"
    and "𝔊' = smcf_dghm 𝔊"
    and "𝔄' = smc_dg 𝔄"
    and "𝔅' = smc_dg 𝔅"
  shows "ntsmcf_tdghm 𝔑 :
    𝔉' ↦DGHM.tm 𝔊' : 𝔄' ↦↦DG.tmα' 𝔅'"
  unfolding assms by (rule tm_ntsmcf_is_tm_tdghm)

lemmas [slicing_intros] = is_tm_ntsmcf.tm_ntsmcf_is_tm_tdghm'


text‹Rules.›

lemma (in is_tm_ntsmcf) is_tm_ntsmcf_axioms'[smc_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "𝔑 : 𝔉' ↦SMCF.tm 𝔊' : 𝔄' ↦↦SMC.tmα 𝔅'"
  unfolding assms by (rule is_tm_ntsmcf_axioms)

mk_ide rf is_tm_ntsmcf_def[unfolded is_tm_ntsmcf_axioms_def]
  |intro is_tm_ntsmcfI|
  |dest is_tm_ntsmcfD[dest]|
  |elim is_tm_ntsmcfE[elim]|

lemmas [smc_small_cs_intros] = is_tm_ntsmcfD(1)


text‹Slicing.›

context is_tm_ntsmcf
begin

interpretation tdghm: is_tm_tdghm
  α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉› ‹smcf_dghm 𝔊› ‹ntsmcf_tdghm 𝔑›
  by (rule tm_ntsmcf_is_tm_tdghm)

lemmas_with [unfolded slicing_simps]:
  tm_ntsmcf_NTMap_in_Vset = tdghm.tm_tdghm_NTMap_in_Vset

end


text‹Elementary properties.›

sublocale is_tm_ntsmcf ⊆ NTDom: is_tm_semifunctor α 𝔄 𝔅 𝔉 
  using tm_ntsmcf_is_tm_tdghm 
  by (intro is_tm_semifunctorI) (auto simp: smc_cs_intros)

sublocale is_tm_ntsmcf ⊆ NTCod: is_tm_semifunctor α 𝔄 𝔅 𝔊
  using tm_ntsmcf_is_tm_tdghm 
  by (intro is_tm_semifunctorI) (auto simp: smc_cs_intros)


text‹Further rules.›

lemma is_tm_ntsmcfI':
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
proof-
  interpret is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret 𝔉: is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
  interpret 𝔊: is_tm_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(3))
  show ?thesis
  proof(intro is_tm_ntsmcfI)
    show "ntsmcf_tdghm 𝔑 :
      smcf_dghm 𝔉 ↦DGHM.tm smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DG.tmα smc_dg 𝔅"
      by (intro is_tm_tdghmI) (auto simp: slicing_intros)
  qed (auto simp: assms(2,3) vfsequence_axioms smc_cs_intros)
qed

lemma is_tm_ntsmcfD':
  assumes "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
proof-
  interpret is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  show "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
    by (auto simp: smc_small_cs_intros)
qed

lemmas [smc_small_cs_intros] = is_tm_ntsmcfD'(2,3)


text‹Size.›

lemma small_all_tm_ntsmcfs[simp]: 
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"
proof(rule down)
  show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅} ⊆ 
    elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_ntsmcfs if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
    then obtain 𝔉 𝔊 𝔄 𝔅 where "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
      by clarsimp
    then interpret is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
    have "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" by (auto simp: smc_cs_intros)
    then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" by auto
  qed
qed

lemma small_tm_ntsmcfs[simp]: 
  "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}›
          ]
    )
    auto

lemma small_these_tm_ntsmcfs[simp]: 
  "small {𝔑. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}"
  by 
    (
      rule 
        down[
          of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅}›
          ]
    ) 
    auto


text‹Further elementary results.›

lemma these_tm_ntsmcfs_iff(*not simp*): 
  "𝔑 ∈∘ these_tm_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷
    𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
  by auto


subsubsection‹
Opposite natural transformation of semifunctors with tiny maps
›

lemma (in is_tm_ntsmcf) is_tm_ntsmcf_op: "op_ntsmcf 𝔑 : 
  op_smcf 𝔊 ↦SMCF.tm op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.tmα op_smc 𝔅"
  by (intro is_tm_ntsmcfI') 
    (cs_concl cs_intro: smc_cs_intros smc_op_intros)+

lemma (in is_tm_ntsmcf) is_tm_ntsmcf_op'[smc_op_intros]: 
  assumes "𝔊' = op_smcf 𝔊"
    and "𝔉' = op_smcf 𝔉"
    and "𝔄' = op_smc 𝔄"
    and "𝔅' = op_smc 𝔅"
  shows "op_ntsmcf 𝔑 : 𝔊' ↦SMCF.tm 𝔉' : 𝔄' ↦↦SMC.tmα 𝔅'"
  unfolding assms by (rule is_tm_ntsmcf_op)

lemmas is_tm_ntsmcf_op[smc_op_intros] = is_tm_ntsmcf.is_tm_ntsmcf_op'


subsubsection‹
Vertical composition of natural transformations of 
semifunctors with tiny maps
›

lemma ntsmcf_vcomp_is_tm_ntsmcf[smc_small_cs_intros]:
  assumes "𝔐 : 𝔊 ↦SMCF.tm ℌ : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "𝔐 ∙NTSMCF 𝔑 : 𝔉 ↦SMCF.tm ℌ : 𝔄 ↦↦SMC.tmα 𝔅"
proof-
  interpret 𝔐: is_tm_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
  interpret 𝔑: is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis 
    by (rule is_tm_ntsmcfI') (auto intro: smc_cs_intros smc_small_cs_intros)
qed 


subsubsection‹
Composition of a natural transformation of semifunctors and a semifunctor
›

lemma ntsmcf_smcf_comp_is_tm_ntsmcf:
  assumes "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔅 ↦↦SMC.tmα ℭ" and "ℌ : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "𝔑 ∘NTSMCF-SMCF ℌ : 𝔉 ∘SMCF ℌ ↦SMCF.tm 𝔊 ∘SMCF ℌ : 𝔄 ↦↦SMC.tmα ℭ"
proof-
  interpret 𝔑: is_tm_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
  interpret ℌ: is_tm_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
  from assms show ?thesis
    by (intro is_tm_ntsmcfI)
      (
        cs_concl 
          cs_simp: slicing_commute[symmetric] 
          cs_intro: smc_cs_intros dg_small_cs_intros slicing_intros
      )+
qed

lemma ntsmcf_smcf_comp_is_tm_ntsmcf'[smc_small_cs_intros]:
  assumes "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔅 ↦↦SMC.tmα ℭ" 
    and "ℌ : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔉' = 𝔉 ∘SMCF ℌ"
    and "𝔊' = 𝔊 ∘SMCF ℌ"
  shows "𝔑 ∘NTSMCF-SMCF ℌ : 𝔉' ↦SMCF.tm 𝔊' : 𝔄 ↦↦SMC.tmα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule ntsmcf_smcf_comp_is_tm_ntsmcf)


subsubsection‹
Composition of a semifunctor and a natural transformation of semifunctors
›

lemma smcf_ntsmcf_comp_is_tm_ntsmcf:
  assumes "ℌ : 𝔅 ↦↦SMC.tmα ℭ" and "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
  shows "ℌ ∘SMCF-NTSMCF 𝔑 : ℌ ∘SMCF 𝔉 ↦SMCF.tm ℌ ∘SMCF 𝔊 : 𝔄 ↦↦SMC.tmα ℭ"
proof-
  interpret ℌ: is_tm_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
  interpret 𝔑: is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  from assms show ?thesis
    by (intro is_tm_ntsmcfI)
      (
        cs_concl 
          cs_simp: slicing_commute[symmetric] 
          cs_intro: smc_cs_intros dg_small_cs_intros slicing_intros
      )+
qed

lemma smcf_ntsmcf_comp_is_tm_ntsmcf'[smc_small_cs_intros]:
  assumes "ℌ : 𝔅 ↦↦SMC.tmα ℭ" 
    and "𝔑 : 𝔉 ↦SMCF.tm 𝔊 : 𝔄 ↦↦SMC.tmα 𝔅"
    and "𝔉' = ℌ ∘SMCF 𝔉"
    and "𝔊' = ℌ ∘SMCF 𝔊"
  shows "ℌ ∘SMCF-NTSMCF 𝔑 : 𝔉' ↦SMCF.tm 𝔊' : 𝔄 ↦↦SMC.tmα ℭ"
  using assms(1,2) unfolding assms(3,4) by (rule smcf_ntsmcf_comp_is_tm_ntsmcf)



subsection‹Tiny natural transformation of semifunctors›


subsubsection‹Definition and elementary properties›

locale is_tiny_ntsmcf = is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
  assumes tiny_ntsmcf_is_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
    smcf_dghm 𝔉 ↦DGHM.tiny smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DG.tinyα smc_dg 𝔅" 

syntax "_is_tiny_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
  (‹(_ :/ _ ↦SMCF.tiny _ :/ _ ↦↦SMC.tinyı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅" ⇌
  "CONST is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"

abbreviation all_tiny_ntsmcfs :: "V ⇒ V"
  where "all_tiny_ntsmcfs α ≡
    set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"

abbreviation tiny_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
  where "tiny_ntsmcfs α 𝔄 𝔅 ≡ 
    set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"

abbreviation these_tiny_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
  where "these_tiny_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡ 
    set {𝔑. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"

lemma (in is_tiny_ntsmcf) tiny_ntsmcf_is_tdghm':
  assumes "α' = α"
    and "𝔉' = smcf_dghm 𝔉"
    and "𝔊' = smcf_dghm 𝔊"
    and "𝔄' = smc_dg 𝔄"
    and "𝔅' = smc_dg 𝔅"
  shows "ntsmcf_tdghm 𝔑 : 𝔉' ↦DGHM.tiny 𝔊' : 𝔄' ↦↦DG.tinyα' 𝔅'"
  unfolding assms by (rule tiny_ntsmcf_is_tdghm)

lemmas [slicing_intros] = is_tiny_ntsmcf.tiny_ntsmcf_is_tdghm'


text‹Rules.›

lemma (in is_tiny_ntsmcf) is_tiny_ntsmcf_axioms'[smc_small_cs_intros]:
  assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
  shows "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  unfolding assms by (rule is_tiny_ntsmcf_axioms)

mk_ide rf is_tiny_ntsmcf_def[unfolded is_tiny_ntsmcf_axioms_def]
  |intro is_tiny_ntsmcfI|
  |dest is_tiny_ntsmcfD[dest]|
  |elim is_tiny_ntsmcfE[elim]|


text‹Elementary properties.›

sublocale is_tiny_ntsmcf ⊆ NTDom: is_tiny_semifunctor α 𝔄 𝔅 𝔉 
  using tiny_ntsmcf_is_tdghm 
  by (intro is_tiny_semifunctorI) (auto simp: smc_cs_intros)

sublocale is_tiny_ntsmcf ⊆ NTCod: is_tiny_semifunctor α 𝔄 𝔅 𝔊
  using tiny_ntsmcf_is_tdghm 
  by (intro is_tiny_semifunctorI) (auto simp: smc_cs_intros)

sublocale is_tiny_ntsmcf ⊆ is_tm_ntsmcf
  by (rule is_tm_ntsmcfI')
    (auto simp: tiny_ntsmcf_is_tdghm smc_small_cs_intros smc_cs_intros)


text‹Further rules.›

lemma is_tiny_ntsmcfI':
  assumes "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  shows "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  using assms by (auto intro: is_tiny_ntsmcfI)

lemma is_tiny_ntsmcfD':
  assumes "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  shows "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
proof-
  interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
  show "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
    by 
      (
        auto 
          simp: is_ntsmcf_axioms 
          intro:  
            NTDom.is_tiny_semifunctor_axioms 
            NTCod.is_tiny_semifunctor_axioms
      )
qed

lemmas [smc_small_cs_intros] = is_tiny_ntsmcfD'(2,3)

lemma is_tiny_ntsmcfE':
  assumes "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  obtains "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅"
    and "𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅"
    and "𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  using assms by (auto dest: is_tiny_ntsmcfD'(2,3))

lemma is_tiny_ntsmcf_iff:
  "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅 ⟷
    (
      𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅 ∧
      𝔉 : 𝔄 ↦↦SMC.tinyα 𝔅 ∧
      𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅
    )"
  using is_tiny_ntsmcfI' is_tiny_ntsmcfD' by (intro iffI) auto


text‹Size.›

lemma (in is_tiny_ntsmcf) tiny_ntsmcf_in_Vset: "𝔑 ∈∘ Vset α"
proof-
  note [smc_cs_intros] =
    tm_ntsmcf_NTMap_in_Vset
    NTDom.tiny_smcf_in_Vset
    NTCod.tiny_smcf_in_Vset
    NTDom.HomDom.tiny_smc_in_Vset
    NTDom.HomCod.tiny_smc_in_Vset
  show ?thesis
    by (subst ntsmcf_def) 
      (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed

lemma small_all_tiny_ntsmcfs[simp]: 
  "small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"
proof(rule down)
  show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅} ⊆ 
    elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅})"
  proof
    (
      simp only: elts_of_set small_all_ntsmcfs if_True, 
      rule subsetI, 
      unfold mem_Collect_eq
    )
    fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
    then obtain 𝔉 𝔊 𝔄 𝔅 where "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
      by clarsimp
    then interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
    have "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" 
      by (auto intro: smc_cs_intros)
    then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCα 𝔅" by auto
  qed
qed

lemma small_tiny_ntsmcfs[simp]: 
  "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"
  by 
    (
      rule 
        down[
          of 
            _ 
            ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}›
          ]
    )
    auto

lemma small_these_tiny_ntcfs[simp]: 
  "small {𝔑. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}"
  by 
    (
      rule down[
        of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅}›
        ]
    ) 
    auto

lemma tiny_ntsmcfs_vsubset_Vset[simp]: 
  "set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅} ⊆∘ Vset α"
  (is ‹set ?ntsmcfs ⊆∘ _›)
proof(cases ‹tiny_semicategory α 𝔄 ∧ tiny_semicategory α 𝔅›)
  case True
  then have "tiny_semicategory α 𝔄" and "tiny_semicategory α 𝔅" by auto
  show ?thesis 
  proof(rule vsubsetI)
    fix 𝔑 assume "𝔑 ∈∘ set ?ntsmcfs"
    then obtain 𝔉 𝔊 where "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅" by auto
    then interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
    from tiny_ntsmcf_in_Vset show "𝔑 ∈∘ Vset α" by simp
  qed
next
  case False
  then have "set ?ntsmcfs = 0" 
    unfolding is_tiny_ntsmcf_iff is_tiny_semifunctor_iff by auto
  then show ?thesis by simp
qed

lemma (in is_ntsmcf) ntsmcf_is_tiny_ntsmcf_if_ge_Limit:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyβ 𝔅" 
proof(intro is_tiny_ntsmcfI)
  interpret β: 𝒵 β by (rule assms(1))
  show "𝔑 : 𝔉 ↦SMCF 𝔊 : 𝔄 ↦↦SMCβ 𝔅"
    by (intro ntsmcf_is_ntsmcf_if_ge_Limit)
      (use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
  show "ntsmcf_tdghm 𝔑 :
    smcf_dghm 𝔉 ↦DGHM.tiny smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦DG.tinyβ smc_dg 𝔅"
    by 
      ( 
        rule is_tdghm.tdghm_is_tiny_tdghm_if_ge_Limit, 
        rule ntsmcf_is_tdghm;
        intro assms
     )
qed


text‹Further elementary results.›

lemma these_tiny_ntsmcfs_iff(*not simp*):
  "𝔑 ∈∘ these_tiny_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷
    𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  by auto


subsubsection‹Opposite natural transformation of tiny semifunctors›

lemma (in is_tiny_ntsmcf) is_tm_ntsmcf_op: "op_ntsmcf 𝔑 :
  op_smcf 𝔊 ↦SMCF.tiny op_smcf 𝔉 : op_smc 𝔄 ↦↦SMC.tinyα op_smc 𝔅"
  by (intro is_tiny_ntsmcfI')
    (cs_concl cs_intro: smc_cs_intros smc_op_intros)+

lemma (in is_tiny_ntsmcf) is_tiny_ntsmcf_op'[smc_op_intros]: 
  assumes "𝔊' = op_smcf 𝔊"
    and "𝔉' = op_smcf 𝔉"
    and "𝔄' = op_smc 𝔄"
    and "𝔅' = op_smc 𝔅"
  shows "op_ntsmcf 𝔑 : 𝔊' ↦SMCF.tiny 𝔉' : 𝔄' ↦↦SMC.tinyα 𝔅'"
  unfolding assms by (rule is_tm_ntsmcf_op)

lemmas is_tiny_ntsmcf_op[smc_op_intros] = is_tiny_ntsmcf.is_tiny_ntsmcf_op'


subsubsection‹
Vertical composition of tiny natural transformations of 
semifunctors
›

lemma ntsmcf_vcomp_is_tiny_ntsmcf[smc_small_cs_intros]:
  assumes "𝔐 : 𝔊 ↦SMCF.tiny ℌ : 𝔄 ↦↦SMC.tinyα 𝔅"
    and "𝔑 : 𝔉 ↦SMCF.tiny 𝔊 : 𝔄 ↦↦SMC.tinyα 𝔅"
  shows "𝔐 ∙NTSMCF 𝔑 : 𝔉 ↦SMCF.tiny ℌ : 𝔄 ↦↦SMC.tinyα 𝔅"
proof-
  interpret 𝔐: is_tiny_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
  interpret 𝔑: is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
  show ?thesis by (rule is_tiny_ntsmcfI') (auto intro: smc_small_cs_intros)
qed

text‹\newpage›

end

Theory CZH_SMC_PSemicategory

(* Copyright 2021 (C) Mihails Milehins *)

section‹Product semicategory›
theory CZH_SMC_PSemicategory
  imports 
    CZH_SMC_Semifunctor
    CZH_SMC_Small_Semicategory
    CZH_DG_PDigraph
begin



subsection‹Background›


text‹
The concept of a product semicategory, as presented in this work, 
is a generalization of the concept of a product category, as presented in
Chapter II-3 in \cite{mac_lane_categories_2010}.
›

named_theorems smc_prod_cs_simps
named_theorems smc_prod_cs_intros



subsection‹Product semicategory: definition and elementary properties›

definition smc_prod :: "V ⇒ (V ⇒ V) ⇒ V" 
  where "smc_prod I 𝔄 = 
    [
      (∏∘i∈∘I. 𝔄 i⦇Obj⦈), 
      (∏∘i∈∘I. 𝔄 i⦇Arr⦈), 
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)), 
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)),
      (λgf∈∘composable_arrs (dg_prod I 𝔄). (λi∈∘I. gf⦇0⦈⦇i⦈ ∘A𝔄 i gf⦇1ℕ⦈⦇i⦈))
    ]∘"

syntax "_PSEMICATEGORY" :: "pttrn ⇒ V ⇒ (V ⇒ V) ⇒ V" 
  ("(3∏SMC_∈∘_./ _)" [0, 0, 10] 10)
translations "∏SMCi∈∘I. 𝔄" ⇌ "CONST smc_prod I (λi. 𝔄)"


text‹Components.›

lemma smc_prod_components:
  shows "(∏SMCi∈∘I. 𝔄 i)⦇Obj⦈ = (∏∘i∈∘I. 𝔄 i⦇Obj⦈)"
    and "(∏SMCi∈∘I. 𝔄 i)⦇Arr⦈ = (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
    and "(∏SMCi∈∘I. 𝔄 i)⦇Dom⦈ = 
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈))"
    and "(∏SMCi∈∘I. 𝔄 i)⦇Cod⦈ = 
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). (λi∈∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))"
    and "(∏SMCi∈∘I. 𝔄 i)⦇Comp⦈ = 
      (λgf∈∘composable_arrs (dg_prod I 𝔄). (λi∈∘I. gf⦇0⦈⦇i⦈ ∘A𝔄 i gf⦇1ℕ⦈⦇i⦈))"
  unfolding smc_prod_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_smc_prod[slicing_commute]: 
  "dg_prod I (λi. smc_dg (𝔄 i)) = smc_dg (smc_prod I 𝔄)"
  unfolding dg_prod_def smc_dg_def smc_prod_def dg_field_simps
  by (simp_all add: nat_omega_simps)

context
  fixes 𝔄 φ :: "V ⇒ V"
    and ℭ :: V
begin

lemmas_with 
  [where 𝔄=‹λi. smc_dg (𝔄 i)›, unfolded slicing_simps slicing_commute]:
  smc_prod_ObjI = dg_prod_ObjI
  and smc_prod_ObjD = dg_prod_ObjD
  and smc_prod_ObjE = dg_prod_ObjE
  and smc_prod_Obj_cong = dg_prod_Obj_cong
  and smc_prod_ArrI = dg_prod_ArrI
  and smc_prod_ArrD = dg_prod_ArrD
  and smc_prod_ArrE = dg_prod_ArrE
  and smc_prod_Arr_cong = dg_prod_Arr_cong
  and smc_prod_Dom_vsv[smc_cs_intros] = dg_prod_Dom_vsv
  and smc_prod_Dom_vdomain[smc_cs_simps] = dg_prod_Dom_vdomain
  and smc_prod_Dom_app = dg_prod_Dom_app
  and smc_prod_Dom_app_component_app[smc_cs_simps] = 
    dg_prod_Dom_app_component_app
  and smc_prod_Cod_vsv[smc_cs_intros] = dg_prod_Cod_vsv
  and smc_prod_Cod_app = dg_prod_Cod_app
  and smc_prod_Cod_vdomain[smc_cs_simps] = dg_prod_Cod_vdomain
  and smc_prod_Cod_app_component_app[smc_cs_simps] = 
    dg_prod_Cod_app_component_app
  and smc_prod_vunion_Obj_in_Obj = dg_prod_vunion_Obj_in_Obj
  and smc_prod_vdiff_vunion_Obj_in_Obj = dg_prod_vdiff_vunion_Obj_in_Obj
  and smc_prod_vunion_Arr_in_Arr = dg_prod_vunion_Arr_in_Arr
  and smc_prod_vdiff_vunion_Arr_in_Arr = dg_prod_vdiff_vunion_Arr_in_Arr

end

lemma smc_prod_dg_prod_is_arr: 
  "g : b ↦∏DGi∈∘I. 𝔄 i c ⟷ g : b ↦∏SMCi∈∘I. 𝔄 i c"
  unfolding is_arr_def smc_prod_def dg_prod_def dg_field_simps
  by (simp add: nat_omega_simps)

lemma smc_prod_composable_arrs_dg_prod:
  "composable_arrs (∏DGi∈∘I. 𝔄 i) = composable_arrs (∏SMCi∈∘I. 𝔄 i)"
  unfolding composable_arrs_def smc_prod_dg_prod_is_arr by simp



subsection‹Local assumptions for a product semicategory›

locale psemicategory_base = 𝒵 α for α I 𝔄 +
  assumes psmc_semicategories[smc_prod_cs_intros]: 
    "i ∈∘ I ⟹ semicategory α (𝔄 i)"
    and psmc_index_in_Vset[smc_cs_intros]: "I ∈∘ Vset α"


text‹Rules.›

lemma (in psemicategory_base) psemicategory_base_axioms'[smc_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "psemicategory_base α' I' 𝔄"
  unfolding assms by (rule psemicategory_base_axioms)

mk_ide rf psemicategory_base_def[unfolded psemicategory_base_axioms_def]
  |intro psemicategory_baseI|
  |dest psemicategory_baseD[dest]|
  |elim psemicategory_baseE[elim]|

lemma psemicategory_base_pdigraph_baseI:
  assumes "pdigraph_base α I (λi. smc_dg (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ semicategory α (𝔄 i)"
  shows "psemicategory_base α I 𝔄"
proof-
  interpret pdigraph_base α I ‹λi. smc_dg (𝔄 i)›
    rewrites "smc_dg ℭ'⦇Obj⦈ = ℭ'⦇Obj⦈" and "smc_dg ℭ'⦇Arr⦈ = ℭ'⦇Arr⦈" for ℭ'
    by (rule assms(1)) (simp_all add: slicing_simps)
  show ?thesis
    by (intro psemicategory_baseI)
      (auto simp: assms(2) pdg_index_in_Vset pdg_Obj_in_Vset pdg_Arr_in_Vset) 
qed


text‹Product semicategory is a product digraph.›

context psemicategory_base
begin

lemma psmc_pdigraph_base: "pdigraph_base α I (λi. smc_dg (𝔄 i))"
proof(intro pdigraph_baseI)
  show "digraph α (smc_dg (𝔄 i))" if "i ∈∘ I" for i 
    using that by (cs_concl cs_intro: slicing_intros smc_prod_cs_intros)
  show "I ∈∘ Vset α" by (cs_concl cs_intro: smc_cs_intros)
qed auto

interpretation pdg: pdigraph_base α I ‹λi. smc_dg (𝔄 i)› 
  by (rule psmc_pdigraph_base)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  psmc_Obj_in_Vset = pdg.pdg_Obj_in_Vset
  and psmc_Arr_in_Vset = pdg.pdg_Arr_in_Vset
  and psmc_smc_prod_Obj_in_Vset = pdg.pdg_dg_prod_Obj_in_Vset
  and psmc_smc_prod_Arr_in_Vset = pdg.pdg_dg_prod_Arr_in_Vset
  and smc_prod_Dom_app_in_Obj[smc_cs_intros] = pdg.dg_prod_Dom_app_in_Obj
  and smc_prod_Cod_app_in_Obj[smc_cs_intros] = pdg.dg_prod_Cod_app_in_Obj
  and smc_prod_is_arrI = pdg.dg_prod_is_arrI
  and smc_prod_is_arrD[dest] = pdg.dg_prod_is_arrD
  and smc_prod_is_arrE[elim] = pdg.dg_prod_is_arrE

end

lemmas [smc_cs_intros] = psemicategory_base.smc_prod_is_arrD(7)


text‹Elementary properties.›

lemma (in psemicategory_base) psmc_vsubset_index_psemicategory_base:
  assumes "J ⊆∘ I"
  shows "psemicategory_base α J 𝔄"
proof(intro psemicategory_baseI)
  show "semicategory α (𝔄 i)" if "i ∈∘ J" for i 
    using that assms by (auto intro: smc_prod_cs_intros)
  from assms show "J ∈∘ Vset α" by (simp add: vsubset_in_VsetI smc_cs_intros)
qed auto


subsubsection‹Composition›

lemma smc_prod_Comp:
  "(∏SMCi∈∘I. 𝔄 i)⦇Comp⦈ = 
    (
      λgf∈∘composable_arrs (∏SMCi∈∘I. 𝔄 i). 
        (λi∈∘I. gf⦇0⦈⦇i⦈ ∘A𝔄 i gf⦇1ℕ⦈⦇i⦈)
    )"
  unfolding smc_prod_components smc_prod_composable_arrs_dg_prod by simp

lemma smc_prod_Comp_vdomain[smc_cs_simps]: 
  "𝒟∘ ((∏SMCi∈∘I. 𝔄 i)⦇Comp⦈) = composable_arrs (∏SMCi∈∘I. 𝔄 i)" 
  unfolding smc_prod_Comp by simp

lemma smc_prod_Comp_app: 
  assumes "g : b ↦∏SMCi∈∘I. 𝔄 i c" and "f : a ↦∏SMCi∈∘I. 𝔄 i b"
  shows "g ∘A(∏SMCi∈∘I. 𝔄 i) f = (λi∈∘I. g⦇i⦈ ∘A𝔄 i f⦇i⦈)" 
proof-
  from assms have "[g, f]∘ ∈∘ composable_arrs (∏SMCi∈∘I. 𝔄 i)" 
    by (auto intro: smc_cs_intros)  
  then show ?thesis unfolding smc_prod_Comp by (auto simp: nat_omega_simps)
qed

lemma smc_prod_Comp_app_component[smc_cs_simps]: 
  assumes "g : b ↦∏SMCi∈∘I. 𝔄 i c" 
    and "f : a ↦∏SMCi∈∘I. 𝔄 i b"
    and "i ∈∘ I"
  shows "(g ∘A(∏SMCi∈∘I. 𝔄 i) f)⦇i⦈ = g⦇i⦈ ∘A𝔄 i f⦇i⦈"
  using assms(3) unfolding smc_prod_Comp_app[OF assms(1,2)] by simp

lemma (in psemicategory_base) smc_prod_Comp_vrange: 
  "ℛ∘ ((∏SMCi∈∘I. 𝔄 i)⦇Comp⦈) ⊆∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈" 
proof(intro vsubsetI)
  fix h assume prems: "h ∈∘ ℛ∘ ((∏SMCi∈∘I. 𝔄 i)⦇Comp⦈)"
  then obtain gf 
    where h_def: "h = (∏SMCi∈∘I. 𝔄 i)⦇Comp⦈⦇gf⦈" 
      and "gf ∈∘ composable_arrs (∏SMCi∈∘I. 𝔄 i)"
    by (auto simp: smc_prod_Comp intro: smc_cs_intros)
  then obtain g f a b c 
    where gf_def: "gf = [g, f]∘" 
      and g: "g : b ↦∏SMCi∈∘I. 𝔄 i c" 
      and f: "f : a ↦∏SMCi∈∘I. 𝔄 i b"
    by clarsimp
  from g f have gf_comp: "g ∘A(∏SMCi∈∘I. 𝔄 i) f = (λi∈∘I. g⦇i⦈ ∘A𝔄 i f⦇i⦈)"
    by (rule smc_prod_Comp_app)
  show "h ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈"
    unfolding smc_prod_components
    unfolding h_def gf_def gf_comp
  proof(rule VLambda_in_vproduct)
    fix i assume prems: "i ∈∘ I"
    interpret semicategory α ‹𝔄 i› 
      using prems by (simp add: smc_prod_cs_intros)
    from prems smc_prod_is_arrD(7)[OF g] smc_prod_is_arrD(7)[OF f] have
      "g⦇i⦈ ∘A𝔄 i f⦇i⦈ : a⦇i⦈ ↦𝔄 i c⦇i⦈" 
      by (auto intro: smc_cs_intros)
    then show "g⦇i⦈ ∘A𝔄 i f⦇i⦈ ∈∘ 𝔄 i⦇Arr⦈" by (simp add: smc_cs_intros)
  qed
qed

lemma smc_prod_Comp_app_vdomain[smc_cs_simps]:
  assumes "g : b ↦∏SMCi∈∘I. 𝔄 i c" and "f : a ↦∏SMCi∈∘I. 𝔄 i b"
  shows "𝒟∘ (g ∘A(∏SMCi∈∘I. 𝔄 i) f) = I" 
  unfolding smc_prod_Comp_app[OF assms] by simp


subsubsection‹A product ‹α›-semicategory is a tiny ‹β›-semicategory›

lemma (in psemicategory_base) psmc_tiny_semicategory_smc_prod:
  assumes "𝒵 β" and "α ∈∘ β" 
  shows "tiny_semicategory β (∏SMCi∈∘I. 𝔄 i)"
proof(intro tiny_semicategoryI, (unfold slicing_simps)?)

  show "tiny_digraph β (smc_dg (smc_prod I 𝔄))"
    unfolding slicing_commute[symmetric]
    by 
      (
        intro pdigraph_base.pdg_tiny_digraph_dg_prod; 
        (rule assms psmc_pdigraph_base)?
      )

  show "vfsequence (∏SMCi∈∘I. 𝔄 i)" unfolding smc_prod_def by auto
  show "vcard (∏SMCi∈∘I. 𝔄 i) = 5ℕ"
    unfolding smc_prod_def by (simp add: nat_omega_simps)
  show "vsv ((∏SMCi∈∘I. 𝔄 i)⦇Comp⦈)" unfolding smc_prod_Comp by simp
  
  show
    "(gf ∈∘ 𝒟∘ ((∏SMCi∈∘I. 𝔄 i)⦇Comp⦈)) ⟷
      (
        ∃g f b c a. 
          gf = [g, f]∘ ∧ g : b ↦smc_prod I 𝔄 c ∧ f : a ↦smc_prod I 𝔄 b
      )"
    for gf
    by (auto intro: smc_cs_intros simp: smc_cs_simps)
  
  show Comp_is_arr[intro]: "g ∘A(∏SMCi∈∘I. 𝔄 i) f : a ↦∏SMCi∈∘I. 𝔄 i c"
    if "g : b ↦∏SMCi∈∘I. 𝔄 i c" and "f : a ↦∏SMCi∈∘I. 𝔄 i b" 
    for g b c f a
  proof(intro smc_prod_is_arrI)
    from that show "vsv (g ∘Asmc_prod I 𝔄 f)" 
      by (auto simp: smc_prod_Comp_app)
    from that show "𝒟∘ (g ∘Asmc_prod I 𝔄 f) = I"
      by (auto simp: smc_prod_Comp_app)
    from that(2) have f: "f ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈"
      by (elim is_arrE) (auto simp: smc_prod_components)
    from that(1) have g: "g ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈"
      by (elim is_arrE) (auto simp: smc_prod_components)
    from f have a: "a ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Obj⦈"
      by (rule smc_prod_Dom_app_in_Obj[of f, unfolded is_arrD(2)[OF that(2)]])
    then show "vsv a" by (auto simp: smc_prod_components)
    from a show "𝒟∘ a = I" by (auto simp: smc_prod_components)
    from g have c: "c ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Obj⦈"
      by (rule smc_prod_Cod_app_in_Obj[of g, unfolded is_arrD(3)[OF that(1)]])
    then show "vsv c" by (auto simp: smc_prod_components)
    from c show "𝒟∘ c = I" by (auto simp: smc_prod_components)
    fix i assume prems: "i ∈∘ I"
    interpret semicategory α ‹𝔄 i› 
      using prems by (auto intro: smc_prod_cs_intros)
    from 
      prems 
      smc_prod_is_arrD(7)[OF that(1) prems] 
      smc_prod_is_arrD(7)[OF that(2) prems] 
    show "(g ∘Asmc_prod I 𝔄 f)⦇i⦈ : a⦇i⦈ ↦𝔄 i c⦇i⦈"
      unfolding smc_prod_Comp_app[OF that] by (auto intro: smc_cs_intros)
  qed
  
  show 
    "h ∘Asmc_prod I 𝔄 g ∘Asmc_prod I 𝔄 f =
      h ∘Asmc_prod I 𝔄 (g ∘Asmc_prod I 𝔄 f)"
    if "h : c ↦smc_prod I 𝔄 d"
      and "g : b ↦smc_prod I 𝔄 c"
      and "f : a ↦smc_prod I 𝔄 b"
    for h c d g b f a
  proof(rule smc_prod_Arr_cong)
    show "(h ∘Asmc_prod I 𝔄 g) ∘Asmc_prod I 𝔄 f ∈∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈"
      by (meson that Comp_is_arr is_arrD)
    show "h ∘Asmc_prod I 𝔄 (g ∘Asmc_prod I 𝔄 f) ∈∘ smc_prod I 𝔄⦇Arr⦈"
      by (meson that Comp_is_arr is_arrD)
    fix i assume prems: "i ∈∘ I"
    then interpret semicategory α ‹𝔄 i› by (simp add: smc_prod_cs_intros)
    from prems that have "h⦇i⦈ : c⦇i⦈ ↦𝔄 i d⦇i⦈"
      and "g⦇i⦈ : b⦇i⦈ ↦𝔄 i c⦇i⦈"
      and "f⦇i⦈ : a⦇i⦈ ↦𝔄 i b⦇i⦈"
      and "h ∘Asmc_prod I 𝔄 g : b ↦smc_prod I 𝔄 d"
      and "g ∘Asmc_prod I 𝔄 f : a ↦smc_prod I 𝔄 c"
      by (auto simp: smc_prod_is_arrD)
    with prems that show 
      "(h ∘Asmc_prod I 𝔄 g ∘Asmc_prod I 𝔄 f)⦇i⦈ =
        (h ∘Asmc_prod I 𝔄 (g ∘Asmc_prod I 𝔄 f))⦇i⦈"
      by (simp add: smc_prod_Comp_app_component smc_Comp_assoc)
  qed

qed (intro assms)



subsection‹Further local assumptions for product semicategories›


subsubsection‹Definition and elementary properties›

locale psemicategory = psemicategory_base α I 𝔄 for α I 𝔄 +
  assumes psmc_Obj_vsubset_Vset: 
    "J ⊆∘ I ⟹ (∏SMCi∈∘J. 𝔄 i)⦇Obj⦈ ⊆∘ Vset α"
    and psmc_Hom_vifunion_in_Vset: 
      "⟦
        J ⊆∘ I;
        A ⊆∘ (∏SMCi∈∘J. 𝔄 i)⦇Obj⦈;
        B ⊆∘ (∏SMCi∈∘J. 𝔄 i)⦇Obj⦈;
        A ∈∘ Vset α;
        B ∈∘ Vset α
      ⟧ ⟹ (⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏SMCi∈∘J. 𝔄 i) a b) ∈∘ Vset α"


text‹Rules.›

lemma (in psemicategory) psemicategory_axioms'[smc_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "psemicategory α' I' 𝔄"
  unfolding assms by (rule psemicategory_axioms)

mk_ide rf psemicategory_def[unfolded psemicategory_axioms_def]
  |intro psemicategoryI|
  |dest psemicategoryD[dest]|
  |elim psemicategoryE[elim]|

lemmas [smc_prod_cs_intros] = psemicategoryD(1)

lemma psemicategory_pdigraphI:
  assumes "pdigraph α I (λi. smc_dg (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ semicategory α (𝔄 i)"
  shows "psemicategory α I 𝔄"
proof-
  interpret pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule assms(1))
  note [unfolded slicing_simps slicing_commute, smc_cs_intros] = 
    pdg_Obj_vsubset_Vset
    pdg_Hom_vifunion_in_Vset
  show ?thesis
    by (intro psemicategoryI psemicategory_base_pdigraph_baseI)
      (auto simp: assms(2) dg_prod_cs_intros intro!: smc_cs_intros) 
qed


text‹Product semicategory is a product digraph.›

context psemicategory
begin

lemma psmc_pdigraph: "pdigraph α I (λi. smc_dg (𝔄 i))"
proof(intro pdigraphI, unfold slicing_simps slicing_commute)
  show "pdigraph_base α I (λi. smc_dg (𝔄 i))" by (rule psmc_pdigraph_base)
qed (auto intro!: psmc_Obj_vsubset_Vset psmc_Hom_vifunion_in_Vset)

interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  psmc_Obj_vsubset_Vset' = pdg.pdg_Obj_vsubset_Vset'
  and psmc_Hom_vifunion_in_Vset' = pdg.pdg_Hom_vifunion_in_Vset'
  and psmc_smc_prod_vunion_is_arr = pdg.pdg_dg_prod_vunion_is_arr
  and psmc_smc_prod_vdiff_vunion_is_arr = pdg.pdg_dg_prod_vdiff_vunion_is_arr

end


text‹Elementary properties.›

lemma (in psemicategory) psmc_vsubset_index_psemicategory:
  assumes "J ⊆∘ I"
  shows "psemicategory α J 𝔄"
proof(intro psemicategoryI psemicategory_pdigraphI)
  show "smc_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" if ‹J' ⊆∘ J› for J'
  proof-
    from that assms have "J' ⊆∘ I" by simp
    then show "smc_prod J' 𝔄⦇Obj⦈ ⊆∘ Vset α" by (rule psmc_Obj_vsubset_Vset)
  qed
  fix A B J' assume prems:
    "J' ⊆∘ J"
    "A ⊆∘ (∏SMCi∈∘J'. 𝔄 i)⦇Obj⦈"
    "B ⊆∘ (∏SMCi∈∘J'. 𝔄 i)⦇Obj⦈"
    "A ∈∘ Vset α" 
    "B ∈∘ Vset α"
  show "(⋃∘a∈∘A. ⋃∘b∈∘B. Hom (∏SMCi∈∘J'. 𝔄 i) a b) ∈∘ Vset α"
  proof-
    from prems(1) assms have "J' ⊆∘ I" by simp
    from psmc_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
  qed
qed (rule psmc_vsubset_index_psemicategory_base[OF assms])


subsubsection‹A product ‹α›-semicategory is an ‹α›-semicategory›

lemma (in psemicategory) psmc_semicategory_smc_prod: 
  "semicategory α (∏SMCi∈∘I. 𝔄 i)"
proof-
  interpret tiny_semicategory ‹α + ω› ‹∏SMCi∈∘I. 𝔄 i›
    by (intro psmc_tiny_semicategory_smc_prod) 
      (auto simp: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
  show ?thesis
    by (rule semicategory_if_semicategory)  
      (
        auto 
          intro!: psmc_Hom_vifunion_in_Vset psmc_Obj_vsubset_Vset
          intro: smc_cs_intros
      )
qed



subsection‹Local assumptions for a finite product semicategory›


subsubsection‹Definition and elementary properties›

locale finite_psemicategory = psemicategory_base α I 𝔄 for α I 𝔄 +
  assumes fin_psmc_index_vfinite: "vfinite I"


text‹Rules.›

lemma (in finite_psemicategory) finite_psemicategory_axioms[smc_prod_cs_intros]: 
  assumes "α' = α" and "I' = I"
  shows "finite_psemicategory α' I' 𝔄"
  unfolding assms by (rule finite_psemicategory_axioms)

mk_ide rf finite_psemicategory_def[unfolded finite_psemicategory_axioms_def]
  |intro finite_psemicategoryI|
  |dest finite_psemicategoryD[dest]|
  |elim finite_psemicategoryE[elim]|

lemmas [smc_prod_cs_intros] = finite_psemicategoryD(1)

lemma finite_psemicategory_finite_pdigraphI:
  assumes "finite_pdigraph α I (λi. smc_dg (𝔄 i))" 
    and "⋀i. i ∈∘ I ⟹ semicategory α (𝔄 i)"
  shows "finite_psemicategory α I 𝔄"
proof-
  interpret finite_pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule assms(1))
  show ?thesis
    by 
      (
        intro 
          assms
          finite_psemicategoryI 
          psemicategory_base_pdigraph_baseI 
          finite_pdigraphD(1)[OF assms(1)]
          fin_pdg_index_vfinite
      )
qed


subsubsection‹
Local assumptions for a finite product semicategory and local
assumptions for an arbitrary product semicategory
›

sublocale finite_psemicategory ⊆ psemicategory α I 𝔄
proof-
  interpret finite_pdigraph α I ‹λi. smc_dg (𝔄 i)›
  proof(intro finite_pdigraphI pdigraph_baseI)
    fix i assume i: "i ∈∘ I"
    interpret 𝔄i: semicategory α ‹𝔄 i› by (simp add: i psmc_semicategories)
    show "digraph α (smc_dg (𝔄 i))" by (simp add: 𝔄i.smc_digraph)
  qed (auto intro!: smc_cs_intros fin_psmc_index_vfinite)
  show "psemicategory α I 𝔄"
    by (intro psemicategory_pdigraphI) 
      (simp_all add: psmc_semicategories pdigraph_axioms)
qed



subsection‹Binary union and complement›

lemma (in psemicategory) psmc_smc_prod_vunion_Comp:
  assumes "vdisjnt J K"
    and "J ⊆∘ I"
    and "K ⊆∘ I"
    and "g : b ↦(∏SMCj∈∘J. 𝔄 j) c"
    and "g' : b' ↦(∏SMCk∈∘K. 𝔄 k) c'"
    and "f : a ↦(∏SMCj∈∘J. 𝔄 j) b"
    and "f' : a' ↦(∏SMCk∈∘K. 𝔄 k) b'"
  shows "(g ∘A(∏SMCj∈∘J. 𝔄 j) f) ∪∘ (g' ∘A(∏SMCj∈∘K. 𝔄 j) f') = 
    g ∪∘ g' ∘A(∏SMCj∈∘J ∪∘ K. 𝔄 j) f ∪∘ f'"
proof-

  interpret J𝔄: psemicategory α J 𝔄 
    using assms(2) by (simp add: psmc_vsubset_index_psemicategory)
  interpret K𝔄: psemicategory α K 𝔄 
    using assms(3) by (simp add: psmc_vsubset_index_psemicategory)
  interpret JK𝔄: psemicategory α ‹J ∪∘ K› 𝔄 
    using assms(2,3) by (simp add: psmc_vsubset_index_psemicategory)

  interpret J𝔄': semicategory α ‹smc_prod J 𝔄› 
    by (rule J𝔄.psmc_semicategory_smc_prod)
  interpret K𝔄': semicategory α ‹smc_prod K 𝔄› 
    by (rule K𝔄.psmc_semicategory_smc_prod)
  interpret JK𝔄': semicategory α ‹smc_prod (J ∪∘ K) 𝔄› 
    by (rule JK𝔄.psmc_semicategory_smc_prod)

  note gg' = psmc_smc_prod_vunion_is_arr[OF assms(1-3,4,5)]
    and ff' = psmc_smc_prod_vunion_is_arr[OF assms(1-3,6,7)]

  note gD = J𝔄.smc_prod_is_arrD[OF assms(4)]
    and g'D = K𝔄.smc_prod_is_arrD[OF assms(5)]
    and fD = J𝔄.smc_prod_is_arrD[OF assms(6)]
    and f'D = K𝔄.smc_prod_is_arrD[OF assms(7)]

  from assms(4,6) have gf: 
    "g ∘Asmc_prod J 𝔄 f : a ↦(∏SMCj∈∘J. 𝔄 j) c" 
    by (auto intro: smc_cs_intros)
  from assms(5,7) have g'f': 
    "g' ∘Asmc_prod K 𝔄 f' : a' ↦(∏SMCk∈∘K. 𝔄 k) c'"
    by (auto intro: smc_cs_intros)
  from gf have "g ∘Asmc_prod J 𝔄 f ∈∘ smc_prod J 𝔄⦇Arr⦈" by auto
  from g'f' have "g' ∘Asmc_prod K 𝔄 f' ∈∘ smc_prod K 𝔄⦇Arr⦈" by auto
  from gg' ff' have gg'_ff': 
    "g ∪∘ g' ∘Asmc_prod (J ∪∘ K) 𝔄 f ∪∘ f' :
      a ∪∘ a' ↦smc_prod (J ∪∘ K) 𝔄 c ∪∘ c'"
    by (simp add: smc_cs_intros)

  show ?thesis
  proof(rule smc_prod_Arr_cong[of _ ‹J ∪∘ K› 𝔄])
    from gf g'f' assms(1) show 
      "(g ∘Asmc_prod J 𝔄 f) ∪∘ (g' ∘Asmc_prod K 𝔄 f') ∈∘ 
        smc_prod (J ∪∘ K) 𝔄⦇Arr⦈"
      by (auto intro: smc_prod_vunion_Arr_in_Arr)
    from gg'_ff' show 
      "g ∪∘ g' ∘Asmc_prod (J ∪∘ K) 𝔄 f ∪∘ f' ∈∘ smc_prod (J ∪∘ K) 𝔄⦇Arr⦈"
      by auto
    fix i assume prems: "i ∈∘ J ∪∘ K"
    then consider (iJ) ‹i ∈∘ J› | (iK) ‹i ∈∘ K› by auto
    then show 
      "((g ∘Asmc_prod J 𝔄 f) ∪∘ (g' ∘Asmc_prod K 𝔄 f'))⦇i⦈ =
        (g ∪∘ g' ∘Asmc_prod (J ∪∘ K) 𝔄 f ∪∘ f')⦇i⦈"
    proof cases
      case iJ
      have [simp]:
        "((g ∘Asmc_prod J 𝔄 f) ∪∘ (g' ∘Asmc_prod K 𝔄 f'))⦇i⦈ = 
          g⦇i⦈ ∘A𝔄 i f⦇i⦈"
      proof
        (
          fold smc_prod_Comp_app_component[OF assms(4,6) iJ], 
          rule vsv_vunion_app_left
        )
        from gf show "vsv (g ∘Asmc_prod J 𝔄 f)" by auto
        from g'f' show "vsv (g' ∘Asmc_prod K 𝔄 f')" by auto
      qed 
        (
          use assms(4-7) in 
            ‹simp_all add: iJ assms(1) smc_prod_Comp_app_vdomain›
        )
      have gg'_i: "(g ∪∘ g')⦇i⦈ = g⦇i⦈" 
        by (simp add: iJ assms(1) gD(1,2) g'D(1,2))
      have ff'_i: "(f ∪∘ f')⦇i⦈ = f⦇i⦈" 
        by (simp add: iJ assms(1) fD(1,2) f'D(1,2))
      have [simp]: 
        "(g ∪∘ g' ∘Asmc_prod (J ∪∘ K) 𝔄 f ∪∘ f')⦇i⦈ = g⦇i⦈ ∘A𝔄 i f⦇i⦈" 
        by (fold gg'_i ff'_i) 
          (rule smc_prod_Comp_app_component[OF gg' ff' prems])
      show ?thesis by simp
    next
      case iK
      have [simp]:
        "((g ∘Asmc_prod J 𝔄 f) ∪∘ (g' ∘Asmc_prod K 𝔄 f'))⦇i⦈ = 
          g'⦇i⦈ ∘A𝔄 i f'⦇i⦈"
      proof
        (
          fold smc_prod_Comp_app_component[OF assms(5,7) iK], 
          rule vsv_vunion_app_right
        )
        from gf show "vsv (g ∘Asmc_prod J 𝔄 f)" by auto
        from g'f' show "vsv (g' ∘Asmc_prod K 𝔄 f')" by auto
      qed 
        (
          use assms(4-7) in 
            ‹simp_all add: iK smc_prod_Comp_app_vdomain assms(1)›
        )
      have gg'_i: "(g ∪∘ g')⦇i⦈ = g'⦇i⦈" 
        by (simp add: iK assms(1) gD(1,2) g'D(1,2))
      have ff'_i: "(f ∪∘ f')⦇i⦈ = f'⦇i⦈" 
        by (simp add: iK assms(1) fD(1,2) f'D(1,2))
      have [simp]:
        "(g ∪∘ g' ∘Asmc_prod (J ∪∘ K) 𝔄 f ∪∘ f')⦇i⦈ = g'⦇i⦈ ∘A𝔄 i f'⦇i⦈" 
        by (fold gg'_i ff'_i)
          (rule smc_prod_Comp_app_component[OF gg' ff' prems])
      show ?thesis by simp
    qed
  qed

qed

lemma (in psemicategory) psmc_smc_prod_vdiff_vunion_Comp:
  assumes "J ⊆∘ I"   
    and "g : b ↦(∏SMCj∈∘I -∘ J. 𝔄 j) c"
    and "g' : b' ↦(∏SMCk∈∘J. 𝔄 k) c'"
    and "f : a ↦(∏SMCj∈∘I -∘ J. 𝔄 j) b"
    and "f' : a' ↦(∏SMCk∈∘J. 𝔄 k) b'"
  shows "(g ∘A(∏SMCj∈∘I -∘ J. 𝔄 j) f) ∪∘ (g' ∘A(∏SMCj∈∘J. 𝔄 j) f') = 
    g ∪∘ g' ∘A(∏SMCj∈∘I. 𝔄 j) f ∪∘ f'"
  by 
    (
      vdiff_of_vunion' 
        rule: psmc_smc_prod_vunion_Comp assms: assms(2-5) subset: assms(1)
    )



subsection‹Projection›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›

definition smcf_proj :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V" (‹πSMC›)
  where "πSMC I 𝔄 i =
    [
      (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). a⦇i⦈),
      (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). f⦇i⦈),
      (∏SMCi∈∘I. 𝔄 i),
      𝔄 i
    ]∘"


text‹Components.›

lemma smcf_proj_components:
  shows "(πSMC I 𝔄 i)⦇ObjMap⦈ = (λa∈∘(∏∘i∈∘I. 𝔄 i⦇Obj⦈). a⦇i⦈)"
    and "(πSMC I 𝔄 i)⦇ArrMap⦈ = (λf∈∘(∏∘i∈∘I. 𝔄 i⦇Arr⦈). f⦇i⦈)"
    and "(πSMC I 𝔄 i)⦇HomDom⦈ = (∏SMCi∈∘I. 𝔄 i)"
    and "(πSMC I 𝔄 i)⦇HomCod⦈ = 𝔄 i"
  unfolding smcf_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing›

lemma smcf_dghm_smcf_proj[slicing_commute]: 
  "πDG I (λi. smc_dg (𝔄 i)) i = smcf_dghm (πSMC I 𝔄 i)"
  unfolding 
    smc_dg_def 
    smcf_dghm_def 
    smcf_proj_def 
    dghm_proj_def 
    smc_prod_def 
    dg_prod_def
    dg_field_simps 
    dghm_field_simps 
  by (simp add: nat_omega_simps)

context psemicategory
begin

interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  smcf_proj_is_dghm = pdg.pdg_dghm_proj_is_dghm

end


subsubsection‹Projection semifunctor is a semifunctor›

lemma (in psemicategory) psmc_smcf_proj_is_semifunctor: 
  assumes "i ∈∘ I"
  shows "πSMC I 𝔄 i : (∏SMCi∈∘I. 𝔄 i) ↦↦SMCα 𝔄 i"
proof(intro is_semifunctorI)
  show "vfsequence (πSMC I 𝔄 i)"
    unfolding smcf_proj_def by (simp add: nat_omega_simps)
  show "vcard (πSMC I 𝔄 i) = 4ℕ"
    unfolding smcf_proj_def by (simp add: nat_omega_simps)
  interpret 𝔄: semicategory α ‹smc_prod I 𝔄› 
    by (rule psmc_semicategory_smc_prod)
  interpret 𝔄i: semicategory α ‹𝔄 i› 
    using assms by (simp add: smc_prod_cs_intros)
  show "πSMC I 𝔄 i⦇ArrMap⦈⦇g ∘Asmc_prod I 𝔄 f⦈ =
    πSMC I 𝔄 i⦇ArrMap⦈⦇g⦈ ∘A𝔄 i πSMC I 𝔄 i⦇ArrMap⦈⦇f⦈"
    if "g : b ↦smc_prod I 𝔄 c" and "f : a ↦smc_prod I 𝔄 b" for g b c f a
  proof-
    from that have "g ∘Asmc_prod I 𝔄 f : a ↦smc_prod I 𝔄 c" 
      by (auto simp: smc_cs_intros)
    then have "g ∘Asmc_prod I 𝔄 f ∈∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)"
      unfolding smc_prod_components[symmetric] by auto
    then have π_gf: "πSMC I 𝔄 i⦇ArrMap⦈⦇g ∘Asmc_prod I 𝔄 f⦈ = g⦇i⦈ ∘A𝔄 i f⦇i⦈"
      unfolding smcf_proj_components 
      by (simp add: smc_prod_Comp_app_component[OF that assms])
    from that(1) have g: "g ∈∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)" 
      unfolding smc_prod_components[symmetric] by auto
    from that(2) have f: "f ∈∘ (∏∘i∈∘I. 𝔄 i⦇Arr⦈)" 
      unfolding smc_prod_components[symmetric] by auto
    from g f have πg_πf: 
      "πSMC I 𝔄 i⦇ArrMap⦈⦇g⦈ ∘A𝔄 i πSMC I 𝔄 i⦇ArrMap⦈⦇f⦈ = g⦇i⦈ ∘A𝔄 i f⦇i⦈"
      unfolding smcf_proj_components by simp
    from π_gf πg_πf show ?thesis by simp
  qed
qed 
  (
    auto simp:
      smc_prod_cs_intros
      assms
      smcf_proj_components
      psmc_semicategory_smc_prod 
      smcf_proj_is_dghm
  )

lemma (in psemicategory) psmc_smcf_proj_is_semifunctor':
  assumes "i ∈∘ I" and "ℭ = (∏SMCi∈∘I. 𝔄 i)" and "𝔇 = 𝔄 i"
  shows "πSMC I 𝔄 i : ℭ ↦↦SMCα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule psmc_smcf_proj_is_semifunctor)

lemmas [smc_cs_intros] = psemicategory.psmc_smcf_proj_is_semifunctor'



subsection‹Semicategory product universal property semifunctor›


subsubsection‹Definition and elementary properties›


text‹
The following semifunctor is used in the 
proof of the universal property of the product semicategory 
later in this work.
›

definition smcf_up :: "V ⇒ (V ⇒ V) ⇒ V ⇒ (V ⇒ V) ⇒ V"
  where "smcf_up I 𝔄 ℭ φ =
    [
      (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈)),
      (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈)),
      ℭ,
      (∏SMCi∈∘I. 𝔄 i)
    ]∘"


text‹Components.›

lemma smcf_up_components: 
  shows "smcf_up I 𝔄 ℭ φ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. (λi∈∘I. φ i⦇ObjMap⦈⦇a⦈))"
    and "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. (λi∈∘I. φ i⦇ArrMap⦈⦇f⦈))"
    and "smcf_up I 𝔄 ℭ φ⦇HomDom⦈ = ℭ"
    and "smcf_up I 𝔄 ℭ φ⦇HomCod⦈ = (∏SMCi∈∘I. 𝔄 i)"
  unfolding smcf_up_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_smcf_up[slicing_commute]: 
  "dghm_up I (λi. smc_dg (𝔄 i)) (smc_dg ℭ) (λi. smcf_dghm (φ i)) = 
    smcf_dghm (smcf_up I 𝔄 ℭ φ)"
  unfolding 
    smc_dg_def 
    smcf_dghm_def 
    smcf_up_def 
    dghm_up_def 
    smc_prod_def 
    dg_prod_def
    dg_field_simps 
    dghm_field_simps 
  by (simp add: nat_omega_simps)

context
  fixes 𝔄 φ :: "V ⇒ V"
    and ℭ :: V
begin

lemmas_with 
  [
    where 𝔄=‹λi. smc_dg (𝔄 i)› and φ=‹λi. smcf_dghm (φ i)› and ℭ=‹smc_dg ℭ›, 
    unfolded slicing_simps slicing_commute
  ]:
  smcf_up_ObjMap_vdomain[smc_cs_simps] = dghm_up_ObjMap_vdomain
  and smcf_up_ObjMap_app = dghm_up_ObjMap_app
  and smcf_up_ObjMap_app_vdomain[smc_cs_simps] = dghm_up_ObjMap_app_vdomain
  and smcf_up_ObjMap_app_component[smc_cs_simps] = dghm_up_ObjMap_app_component
  and smcf_up_ArrMap_vdomain[smc_cs_simps] = dghm_up_ArrMap_vdomain
  and smcf_up_ArrMap_app = dghm_up_ArrMap_app
  and smcf_up_ArrMap_app_vdomain[smc_cs_simps] = dghm_up_ArrMap_app_vdomain
  and smcf_up_ArrMap_app_component[smc_cs_simps] = dghm_up_ArrMap_app_component

lemma smcf_up_ObjMap_vrange:
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i"
  shows "ℛ∘ (smcf_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆∘ (∏SMCi∈∘I. 𝔄 i)⦇Obj⦈"
proof
  (
    rule dghm_up_ObjMap_vrange
      [
        where 𝔄=‹λi. smc_dg (𝔄 i)› 
          and φ=‹λi. smcf_dghm (φ i)› 
          and ℭ=‹smc_dg ℭ›, 
        unfolded slicing_simps slicing_commute
      ]
  )
  fix i assume "i ∈∘ I"
  then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
  show "smcf_dghm (φ i) : smc_dg ℭ ↦↦DGα smc_dg (𝔄 i)" 
    by (rule smcf_is_dghm)
qed

lemma smcf_up_ObjMap_app_vrange:
  assumes "a ∈∘ ℭ⦇Obj⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i"
  shows " ℛ∘ (smcf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Obj⦈)"
proof
  (
    rule dghm_up_ObjMap_app_vrange
      [
        where 𝔄=‹λi. smc_dg (𝔄 i)› 
          and φ=‹λi. smcf_dghm (φ i)› 
          and ℭ=‹smc_dg ℭ›, 
        unfolded slicing_simps slicing_commute
      ]
  )
  show "a ∈∘ ℭ⦇Obj⦈" by (rule assms)
  fix i assume "i ∈∘ I"
  then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
  show "smcf_dghm (φ i) : smc_dg ℭ ↦↦DGα smc_dg (𝔄 i)"
    by (rule smcf_is_dghm)
qed

lemma smcf_up_ArrMap_vrange:
  assumes "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i"
  shows "ℛ∘ (smcf_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆∘ (∏SMCi∈∘I. 𝔄 i)⦇Arr⦈"
proof
  (
    rule dghm_up_ArrMap_vrange
      [
        where 𝔄=‹λi. smc_dg (𝔄 i)› 
          and φ=‹λi. smcf_dghm (φ i)› 
          and ℭ=‹smc_dg ℭ›, 
        unfolded slicing_simps slicing_commute
      ]
  )
  fix i assume "i ∈∘ I"
  then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
  show "smcf_dghm (φ i) : smc_dg ℭ ↦↦DGα smc_dg (𝔄 i)"
    by (rule smcf_is_dghm)
qed

lemma smcf_up_ArrMap_app_vrange:
  assumes "a ∈∘ ℭ⦇Arr⦈" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i"
  shows "ℛ∘ (smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) ⊆∘ (⋃∘i∈∘I. 𝔄 i⦇Arr⦈)"
proof
  (
    rule dghm_up_ArrMap_app_vrange[
      where 𝔄=‹λi. smc_dg (𝔄 i)› 
        and φ=‹λi. smcf_dghm (φ i)› 
        and ℭ=‹smc_dg ℭ›, 
      unfolded slicing_simps slicing_commute
      ]
  )
  show "a ∈∘ ℭ⦇Arr⦈" by (rule assms)
  fix i assume "i ∈∘ I"
  then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
  show "smcf_dghm (φ i) : smc_dg ℭ ↦↦DGα smc_dg (𝔄 i)"
    by (rule smcf_is_dghm)
qed

end

context psemicategory
begin

interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)

lemmas_with [unfolded slicing_simps slicing_commute]: 
  psmc_dghm_comp_dghm_proj_dghm_up = pdg.pdg_dghm_comp_dghm_proj_dghm_up
  and psmc_dghm_up_eq_dghm_proj = pdg.pdg_dghm_up_eq_dghm_proj

end


subsubsection‹
Semicategory product universal property semifunctor is a semifunctor
›

lemma (in psemicategory) psmc_smcf_up_is_semifunctor:
  assumes "semicategory α ℭ" and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i"
  shows "smcf_up I 𝔄 ℭ φ : ℭ ↦↦SMCα (∏SMCi∈∘I. 𝔄 i)"
proof(intro is_semifunctorI)
  interpret ℭ: semicategory α ℭ by (simp add: assms(1))
  interpret 𝔄: semicategory α ‹smc_prod I 𝔄› 
    by (rule psmc_semicategory_smc_prod)
  show "vfsequence (smcf_up I 𝔄 ℭ φ)"
    unfolding smcf_up_def by simp
  show "vcard (smcf_up I 𝔄 ℭ φ) = 4ℕ"
    unfolding smcf_up_def by (simp add: nat_omega_simps)
  show dghm_smcf_up: 
    "smcf_dghm (smcf_up I 𝔄 ℭ φ) : smc_dg ℭ ↦↦DGα smc_dg (smc_prod I 𝔄)"
    by 
      (
        simp add: 
          assms 
          slicing_commute[symmetric]
          psmc_pdigraph 
          is_semifunctor.smcf_is_dghm 
          pdigraph.pdg_dghm_up_is_dghm 
          semicategory.smc_digraph
      )
  interpret smcf_up:
    is_dghm α ‹smc_dg ℭ› ‹smc_dg (smc_prod I 𝔄)› ‹smcf_dghm (smcf_up I 𝔄 ℭ φ)›
    by (rule dghm_smcf_up)
  show "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘Aℭ f⦈ = 
    smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘Asmc_prod I 𝔄 smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈"
    if "g : b ↦ℭ c" and "f : a ↦ℭ b" for g b c f a
  proof(rule smc_prod_Arr_cong[of _ I 𝔄])
    note smcf_up_f = 
        smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF that(2)]
      and smcf_up_g = 
        smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF that(1)]
    from that have gf: "g ∘Aℭ f : a ↦ℭ c" 
      by (simp add: smc_cs_intros)
    from smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF this] show
      "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘Aℭ f⦈ ∈∘ smc_prod I 𝔄⦇Arr⦈" 
      by (simp add: smc_cs_intros)
    from smcf_up_g smcf_up_f show 
      "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘Asmc_prod I 𝔄 smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈ ∈∘ 
        smc_prod I 𝔄⦇Arr⦈"
      by (meson 𝔄.smc_is_arrE 𝔄.smc_Comp_is_arr)
    fix i assume prems: "i ∈∘ I"
    from gf have gf': "g ∘Aℭ f ∈∘ ℭ⦇Arr⦈" by (simp add: smc_cs_intros)
    from that have g: "g ∈∘ ℭ⦇Arr⦈" and f: "f ∈∘ ℭ⦇Arr⦈" by auto
    interpret φ: is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF prems])
    from that show "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘Aℭ f⦈⦇i⦈ = 
      (
        smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘Asmc_prod I 𝔄 smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈
      )⦇i⦈"
      unfolding 
        smcf_up_ArrMap_app_component[OF gf' prems]
        smc_prod_Comp_app_component[OF smcf_up_g smcf_up_f prems]
        smcf_up_ArrMap_app_component[OF g prems]
        smcf_up_ArrMap_app_component[OF f prems]
      by (rule φ.smcf_ArrMap_Comp)
  qed
qed (auto simp: assms(1) psmc_semicategory_smc_prod smcf_up_components)


subsubsection‹Further properties›

lemma (in psemicategory) psmc_Comp_smcf_proj_smcf_up: 
  assumes "semicategory α ℭ" 
    and "⋀i. i ∈∘ I ⟹ φ i : ℭ ↦↦SMCα 𝔄 i" 
    and "i ∈∘ I" 
  shows "φ i = πSMC I 𝔄 i ∘SMCF smcf_up I 𝔄 ℭ φ"
proof(rule smcf_dghm_eqI)
  interpret φ: is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF assms(3)])
  interpret π: is_semifunctor α ‹smc_prod I 𝔄› ‹𝔄 i› ‹πSMC I 𝔄 i›
    by (simp add: assms(3) psmc_smcf_proj_is_semifunctor)
  interpret up: is_semifunctor α ℭ ‹smc_prod I 𝔄› ‹smcf_up I 𝔄 ℭ φ›
    by 
      (
        simp add: 
          assms(2) φ.HomDom.semicategory_axioms psmc_smcf_up_is_semifunctor
      )
  show "φ i : ℭ ↦↦SMCα 𝔄 i" by (simp add: smc_cs_intros)
  show "πSMC I 𝔄 i ∘SMCF smcf_up I 𝔄 ℭ φ : ℭ ↦↦SMCα 𝔄 i" 
      by (auto intro: smc_cs_intros)
  from assms show 
    "smcf_dghm (φ i) = smcf_dghm (πSMC I 𝔄 i ∘SMCF smcf_up I 𝔄 ℭ φ)"
    unfolding slicing_simps[symmetric] slicing_commute[symmetric]
    by 
      (
        intro 
          psmc_dghm_comp_dghm_proj_dghm_up
            [
              where φ=‹λi. smcf_dghm (φ i)›, 
              unfolded slicing_simps[symmetric] slicing_commute[symmetric]
            ]
      )
      (auto simp: is_semifunctor.smcf_is_dghm)
qed simp_all

lemma (in psemicategory) psmc_smcf_up_eq_smcf_proj:
  assumes "𝔉 : ℭ ↦↦SMCα (∏SMCi∈∘I. 𝔄 i)"
    and "⋀i. i ∈∘ I ⟹ φ i = πSMC I 𝔄 i ∘SMCF 𝔉"
  shows "smcf_up I 𝔄 ℭ φ = 𝔉"
proof(rule smcf_dghm_eqI)
  interpret 𝔉: is_semifunctor α ℭ ‹(∏SMCi∈∘I. 𝔄 i)› 𝔉 by (rule assms(1))
  show "smcf_up I 𝔄 ℭ φ : ℭ ↦↦SMCα (∏SMCi∈∘I. 𝔄 i)"
  proof(rule psmc_smcf_up_is_semifunctor)
    fix i assume prems: "i ∈∘ I"
    interpret π: is_semifunctor α ‹(∏SMCi∈∘I. 𝔄 i)› ‹𝔄 i› ‹πSMC I 𝔄 i›
      using prems by (rule psmc_smcf_proj_is_semifunctor)
    show "φ i : ℭ ↦↦SMCα 𝔄 i" 
      unfolding assms(2)[OF prems] by (auto intro: smc_cs_intros)
  qed (auto intro: smc_cs_intros)
  show "𝔉 : ℭ ↦↦SMCα (∏SMCi∈∘I. 𝔄 i)" by (rule assms(1))
  from assms show "smcf_dghm (smcf_up I 𝔄 ℭ φ) = smcf_dghm 𝔉"
    unfolding slicing_simps[symmetric] slicing_commute[symmetric]
    by (intro psmc_dghm_up_eq_dghm_proj) 
      (auto simp: slicing_simps slicing_commute)
qed simp_all



subsection‹Singleton semicategory›


subsubsection‹Slicing›

context
  fixes ℭ :: V
begin

lemmas_with [where ℭ=‹smc_dg ℭ›, unfolded slicing_simps slicing_commute]:
  smc_singleton_ObjI = dg_singleton_ObjI
  and smc_singleton_ObjE = dg_singleton_ObjE
  and smc_singleton_ArrI = dg_singleton_ArrI
  and smc_singleton_ArrE = dg_singleton_ArrE

end

context semicategory
begin

interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)

lemmas_with [unfolded slicing_simps slicing_commute]:
  smc_finite_pdigraph_smc_singleton = dg.dg_finite_pdigraph_dg_singleton
  and smc_singleton_is_arrI = dg.dg_singleton_is_arrI
  and smc_singleton_is_arrD = dg.dg_singleton_is_arrD
  and smc_singleton_is_arrE = dg.dg_singleton_is_arrE

end


subsubsection‹Singleton semicategory is a semicategory›

lemma (in semicategory) smc_finite_psemicategory_smc_singleton: 
  assumes "j ∈∘ Vset α"
  shows "finite_psemicategory α (set {j}) (λi. ℭ)"
  by 
    (
      auto intro: 
        assms
        semicategory_axioms 
        finite_psemicategory_finite_pdigraphI 
        smc_finite_pdigraph_smc_singleton 
    )

lemma (in semicategory) smc_semicategory_smc_singleton:
  assumes "j ∈∘ Vset α"
  shows "semicategory α (∏SMCi∈∘set {j}. ℭ)"
proof-
  interpret finite_psemicategory α ‹set {j}› ‹λi. ℭ›
    using assms by (rule smc_finite_psemicategory_smc_singleton)
  show ?thesis by (rule psmc_semicategory_smc_prod)
qed



subsection‹Singleton semifunctor›


subsubsection‹Definition and elementary properties›

definition smcf_singleton :: "V ⇒ V ⇒ V"
  where "smcf_singleton j ℭ =
    [
      (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩}),
      (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩}),
      ℭ,
      (∏SMCi∈∘set {j}. ℭ)
    ]∘"


text‹Components.›

lemma smcf_singleton_components:
  shows "smcf_singleton j ℭ⦇ObjMap⦈ = (λa∈∘ℭ⦇Obj⦈. set {⟨j, a⟩})"
    and "smcf_singleton j ℭ⦇ArrMap⦈ = (λf∈∘ℭ⦇Arr⦈. set {⟨j, f⟩})"
    and "smcf_singleton j ℭ⦇HomDom⦈ = ℭ"
    and "smcf_singleton j ℭ⦇HomCod⦈ = (∏SMCi∈∘set {j}. ℭ)"
  unfolding smcf_singleton_def dghm_field_simps 
  by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_smcf_singleton[slicing_commute]: 
  "dghm_singleton j (smc_dg ℭ)= smcf_dghm (smcf_singleton j ℭ)"
  unfolding dghm_singleton_def smcf_singleton_def slicing_simps slicing_commute
  by 
    (
      simp add: 
        nat_omega_simps dghm_field_simps dg_field_simps smc_dg_def smcf_dghm_def
     )

context
  fixes ℭ :: V
begin

lemmas_with [where ℭ=‹smc_dg ℭ›, unfolded slicing_simps slicing_commute]:
  smcf_singleton_ObjMap_vsv[smc_cs_intros] = dghm_singleton_ObjMap_vsv
  and smcf_singleton_ObjMap_vdomain[smc_cs_simps] = 
    dghm_singleton_ObjMap_vdomain
  and smcf_singleton_ObjMap_vrange = dghm_singleton_ObjMap_vrange
  and smcf_singleton_ObjMap_app[smc_prod_cs_simps] = dghm_singleton_ObjMap_app
  and smcf_singleton_ArrMap_vsv[smc_cs_intros] = dghm_singleton_ArrMap_vsv
  and smcf_singleton_ArrMap_vdomain[smc_cs_simps] = 
    dghm_singleton_ArrMap_vdomain
  and smcf_singleton_ArrMap_vrange = dghm_singleton_ArrMap_vrange
  and smcf_singleton_ArrMap_app[smc_prod_cs_simps] = dghm_singleton_ArrMap_app

end

context semicategory
begin

interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)

lemmas_with [unfolded slicing_simps slicing_commute]:
  smc_smcf_singleton_is_dghm = dg.dg_dghm_singleton_is_dghm

end


subsubsection‹Singleton semifunctor is an isomorphism of semicategories›

lemma (in semicategory) smc_smcf_singleton_is_iso_semifunctor:
  assumes "j ∈∘ Vset α"
  shows "smcf_singleton j ℭ : ℭ ↦↦SMC.isoα (∏SMCi∈∘set {j}. ℭ)"
proof(intro is_iso_semifunctorI is_semifunctorI)
  show dghm_singleton: 
    "smcf_dghm (smcf_singleton j ℭ) :
      smc_dg ℭ ↦↦DG.isoα smc_dg (∏SMCi∈∘set {j}. ℭ)"
    by (rule smc_smcf_singleton_is_dghm[OF assms, unfolded slicing_simps])
  show "vfsequence (smcf_singleton j ℭ)" unfolding smcf_singleton_def by simp
  show "vcard (smcf_singleton j ℭ) = 4ℕ"
    unfolding smcf_singleton_def by (simp add: nat_omega_simps)
  from dghm_singleton show 
    "smcf_dghm (smcf_singleton j ℭ) :
      smc_dg ℭ ↦↦DGα smc_dg (∏SMCi∈∘set {j}. ℭ)"
    by (simp add: is_iso_dghm.axioms(1))
  show "smcf_singleton j ℭ⦇ArrMap⦈⦇g ∘Aℭ f⦈ =
    smcf_singleton j ℭ⦇ArrMap⦈⦇g⦈ ∘A∏SMCi∈∘set {j}. ℭ
    smcf_singleton j ℭ⦇ArrMap⦈⦇f⦈"
    if "g : b ↦ℭ c" and "f : a ↦ℭ b" for g b c f a
  proof-
    let ?jg = ‹smcf_singleton j ℭ⦇ArrMap⦈⦇g⦈›
      and ?jf = ‹smcf_singleton j ℭ⦇ArrMap⦈⦇f⦈›
    from that have [simp]: "?jg = set {⟨j, g⟩}" "?jf = set {⟨j, f⟩}"
       by (simp_all add: smcf_singleton_ArrMap_app smc_cs_intros)
     from that have "g ∘Aℭ f : a ↦ℭ c" by (auto intro: smc_cs_intros)
    then have "smcf_singleton j ℭ⦇ArrMap⦈⦇g ∘Aℭ f⦈ = set {⟨j, g ∘Aℭ f⟩}"
      by (simp_all add: smcf_singleton_ArrMap_app smc_cs_intros)
    moreover from 
      smc_singleton_is_arrI[OF assms that(1)]
      smc_singleton_is_arrI[OF assms that(2)] 
    have "?jg ∘A∏SMCi∈∘set {j}. ℭ ?jf = set {⟨j, g ∘Aℭ f⟩}"
      by (simp add: smc_prod_Comp_app VLambda_vsingleton)
    ultimately show ?thesis by auto
  qed
qed 
  (
    auto intro:
      smc_cs_intros
      assms 
      smc_semicategory_smc_singleton 
      smcf_singleton_components 
  )

lemmas [smc_cs_intros] = semicategory.smc_smcf_singleton_is_iso_semifunctor



subsection‹Product of two semicategories›


subsubsection‹Definition and elementary properties.›


text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›

definition smc_prod_2 :: "V ⇒ V ⇒ V" (infixr ‹×SMC› 80)
  where "𝔄 ×SMC 𝔅 ≡ smc_prod (2ℕ) (λi. (i = 0 ? 𝔄 : 𝔅))"


text‹Slicing.›
  
lemma smc_dg_smc_prod_2[slicing_commute]: 
  "smc_dg 𝔄 ×DG smc_dg 𝔅 = smc_dg (𝔄 ×SMC 𝔅)"
  unfolding smc_prod_2_def dg_prod_2_def slicing_commute[symmetric] if_distrib
  by simp

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)

lemmas_with 
  [
    where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.smc_digraph 𝔅.smc_digraph
  ]:
  smc_prod_2_ObjI = dg_prod_2_ObjI 
  and smc_prod_2_ObjI'[smc_prod_cs_intros] = dg_prod_2_ObjI'
  and smc_prod_2_ObjE = dg_prod_2_ObjE
  and smc_prod_2_ArrI = dg_prod_2_ArrI
  and smc_prod_2_ArrI'[smc_prod_cs_intros] = dg_prod_2_ArrI'
  and smc_prod_2_ArrE = dg_prod_2_ArrE
  and smc_prod_2_is_arrI = dg_prod_2_is_arrI
  and smc_prod_2_is_arrI'[smc_prod_cs_intros] = dg_prod_2_is_arrI'
  and smc_prod_2_is_arrE = dg_prod_2_is_arrE
  and smc_prod_2_Dom_vsv = dg_prod_2_Dom_vsv
  and smc_prod_2_Dom_vdomain[smc_cs_simps] = dg_prod_2_Dom_vdomain
  and smc_prod_2_Dom_app[smc_prod_cs_simps] = dg_prod_2_Dom_app
  and smc_prod_2_Dom_vrange = dg_prod_2_Dom_vrange
  and smc_prod_2_Cod_vsv = dg_prod_2_Cod_vsv
  and smc_prod_2_Cod_vdomain[smc_cs_simps] = dg_prod_2_Cod_vdomain
  and smc_prod_2_Cod_app[smc_prod_cs_simps] = dg_prod_2_Cod_app
  and smc_prod_2_Cod_vrange = dg_prod_2_Cod_vrange
  and smc_prod_2_op_smc_smc_Obj[smc_op_simps] = dg_prod_2_op_dg_dg_Obj
  and smc_prod_2_smc_op_smc_Obj[smc_op_simps] = dg_prod_2_dg_op_dg_Obj
  and smc_prod_2_op_smc_smc_Arr[smc_op_simps] = dg_prod_2_op_dg_dg_Arr
  and smc_prod_2_smc_op_smc_Arr[smc_op_simps] = dg_prod_2_dg_op_dg_Arr

end


subsubsection‹Product of two semicategories is a semicategory›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)

lemma finite_psemicategory_smc_prod_2: 
  "finite_psemicategory α (2ℕ) (if2 𝔄 𝔅)"
proof(intro finite_psemicategoryI psemicategory_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "2ℕ ∈∘ Vset α" by blast
  show "semicategory α (i = 0 ? 𝔄 : 𝔅)" if "i ∈∘ 2ℕ" for i
    by (auto simp: smc_cs_intros)
qed auto

interpretation finite_psemicategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)

lemma semicategory_smc_prod_2[smc_cs_intros]: "semicategory α (𝔄 ×SMC 𝔅)"
  unfolding smc_prod_2_def by (rule psmc_semicategory_smc_prod)

end


subsubsection‹Composition›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])

interpretation finite_psemicategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)

lemma smc_prod_2_Comp_app[smc_prod_cs_simps]:
  assumes "[g, g']∘ : [b, b']∘ ↦𝔄 ×SMC 𝔅 [c, c']∘" 
    and "[f, f']∘ : [a, a']∘ ↦𝔄 ×SMC 𝔅 [b, b']∘"
  shows "[g, g']∘ ∘A𝔄 ×SMC 𝔅 [f, f']∘ = [g ∘A𝔄 f, g' ∘A𝔅 f']∘"
proof-
  have "[g, g']∘ ∘A𝔄 ×SMC 𝔅 [f, f']∘ = 
    (λi∈∘2ℕ. [g, g']∘⦇i⦈ ∘Ai = 0 ? 𝔄 : 𝔅 [f, f']∘⦇i⦈)"
    by 
      (
        rule smc_prod_Comp_app[
          OF assms[unfolded smc_prod_2_def], folded smc_prod_2_def
          ]
      )
  also have 
    "(λi∈∘2ℕ. [g, g']∘⦇i⦈ ∘Ai = 0 ? 𝔄 : 𝔅 [f, f']∘⦇i⦈) = 
      [g ∘A𝔄 f, g' ∘A𝔅 f']∘"
  proof(rule vsv_eqI, unfold vdomain_VLambda)
    fix i assume "i ∈∘ 2ℕ"
    then consider ‹i = 0› | ‹i = 1ℕ› unfolding two by auto 
    then show 
      "(λi∈∘2ℕ. [g, g']∘⦇i⦈ ∘Ai = 0 ? 𝔄 : 𝔅 [f, f']∘⦇i⦈)⦇i⦈ = 
        [g ∘A𝔄 f, g' ∘A𝔅 f']∘⦇i⦈"
      by cases (simp_all add: two nat_omega_simps)
  qed (auto simp: two nat_omega_simps)
  finally show ?thesis by simp
qed

end


subsubsection‹Opposite product semicategory›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)

lemma op_smc_smc_prod_2[smc_op_simps]: 
  "op_smc (𝔄 ×SMC 𝔅) = op_smc 𝔄 ×SMC op_smc 𝔅"
proof(rule smc_dg_eqI[of α])

  from 𝔄 𝔅 show smc_lhs: "semicategory α (op_smc (𝔄 ×SMC 𝔅))"
    by 
      (
        cs_concl 
          cs_simp: smc_cs_simps smc_op_simps 
          cs_intro: smc_cs_intros smc_op_intros
      )
  interpret smc_lhs: semicategory α ‹op_smc (𝔄 ×SMC 𝔅)› by (rule smc_lhs)
  
  from 𝔄 𝔅 show smc_rhs: "semicategory α (op_smc 𝔄 ×SMC op_smc 𝔅)"
    by 
      (
        cs_concl 
          cs_simp: smc_cs_simps smc_op_simps 
          cs_intro: smc_cs_intros smc_op_intros
      )
  interpret smc_rhs: semicategory α ‹op_smc 𝔄 ×SMC op_smc 𝔅› by (rule smc_rhs)

  show "op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈ = (op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈"
  proof(rule vsv_eqI)
    show "vsv (op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈)"
      unfolding op_smc_components by (rule fflip_vsv)
    show "vsv ((op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈)"
      unfolding smc_prod_2_def smc_prod_components by simp      
    show "𝒟∘ (op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈) = 𝒟∘ ((op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈)"
    proof(intro vsubset_antisym vsubsetI)
      fix gg'ff' assume gf: "gg'ff' ∈∘ 𝒟∘ (op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈)"
      then obtain gg' ff' aa' bb' cc' 
        where gg'ff'_def: "gg'ff' = [gg', ff']∘" 
          and "gg' : bb' ↦op_smc (𝔄 ×SMC 𝔅) cc'" 
          and "ff' : aa' ↦op_smc (𝔄 ×SMC 𝔅) bb'"
        by clarsimp
      then have gg': "gg' : cc' ↦𝔄 ×SMC 𝔅 bb'" 
        and ff': "ff' : bb' ↦𝔄 ×SMC 𝔅 aa'"
        unfolding smc_op_simps by simp_all
      from gg' obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘" 
          and "cc' = [c, c']∘" 
          and "bb' = [b, b']∘"
          and g: "g : c ↦𝔄 b" 
          and g': "g' : c' ↦𝔅 b'"
        by (elim smc_prod_2_is_arrE[OF 𝔄 𝔅])
      with ff' obtain f f' a a' 
        where ff'_def: "ff' = [f, f']∘" 
          and "bb' = [b, b']∘" 
          and "aa' = [a, a']∘"
          and f: "f : b ↦𝔄 a" 
          and f': "f' : b' ↦𝔅 a'"
        by (auto elim: smc_prod_2_is_arrE[OF 𝔄 𝔅])
      from 𝔄 𝔅 g g' f f' show "gg'ff' ∈∘ 𝒟∘ ((op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈)"
        by
          (
            intro smc_rhs.smc_Comp_vdomainI[OF _ _ gg'ff'_def], 
            unfold gg'_def ff'_def
          )
          (
            cs_concl 
              cs_simp: smc_cs_simps smc_op_simps 
              cs_intro: smc_op_intros smc_prod_cs_intros
          )
    next
      fix gg'ff' assume gf: "gg'ff' ∈∘ 𝒟∘ ((op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈)"
      then obtain gg' ff' aa' bb' cc' 
        where gg'ff'_def: "gg'ff' = [gg', ff']∘" 
          and gg': "gg' : bb' ↦op_smc 𝔄 ×SMC op_smc 𝔅 cc'" 
          and ff': "ff' : aa' ↦op_smc 𝔄 ×SMC op_smc 𝔅 bb'"
        by clarsimp
      from gg' obtain g g' b b' c c' 
        where gg'_def: "gg' = [g, g']∘" 
          and "bb' = [b, b']∘"
          and "cc' = [c, c']∘" 
          and g: "g : b ↦op_smc 𝔄 c" 
          and g': "g' : b' ↦op_smc 𝔅 c'"
        by (elim smc_prod_2_is_arrE[OF 𝔄.semicategory_op 𝔅.semicategory_op])
      with ff' obtain f f' a a' 
        where ff'_def: "ff' = [f, f']∘" 
          and "aa' = [a, a']∘"
          and "bb' = [b, b']∘" 
          and f: "f : a ↦op_smc 𝔄 b" 
          and f': "f' : a' ↦op_smc 𝔅 b'"
        by 
          (
            auto elim: 
              smc_prod_2_is_arrE[OF 𝔄.semicategory_op 𝔅.semicategory_op]
          )
      from 𝔄 𝔅 g g' f f' show "gg'ff' ∈∘ 𝒟∘ (op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈)"
        by 
          (
            intro smc_lhs.smc_Comp_vdomainI[OF _ _ gg'ff'_def], 
            unfold gg'_def ff'_def smc_op_simps
          )
          (
            cs_concl 
              cs_simp: smc_cs_simps smc_op_simps 
              cs_intro: smc_op_intros smc_prod_cs_intros
          )
    qed
    fix gg'ff' assume "gg'ff' ∈∘ 𝒟∘ (op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈)"
    then obtain gg' ff' aa' bb' cc' 
      where gg'ff'_def: "gg'ff' = [gg', ff']∘" 
        and "gg' : bb' ↦op_smc (𝔄 ×SMC 𝔅) cc'" 
        and "ff' : aa' ↦op_smc (𝔄 ×SMC 𝔅) bb'"
      by clarsimp
    then have gg': "gg' : cc' ↦𝔄 ×SMC 𝔅 bb'" 
      and ff': "ff' : bb' ↦𝔄 ×SMC 𝔅 aa'"
      unfolding smc_op_simps by simp_all
    from gg' obtain g g' b b' c c' 
      where gg'_def[smc_cs_simps]: "gg' = [g, g']∘" 
        and "cc' = [c, c']∘" 
        and "bb' = [b, b']∘"
        and g: "g : c ↦𝔄 b" 
        and g': "g' : c' ↦𝔅 b'"
      by (elim smc_prod_2_is_arrE[OF 𝔄 𝔅])
    with ff' obtain f f' a a' 
      where ff'_def[smc_cs_simps]: "ff' = [f, f']∘" 
        and "bb' = [b, b']∘" 
        and "aa' = [a, a']∘"
        and f: "f : b ↦𝔄 a" 
        and f': "f' : b' ↦𝔅 a'"
      by (auto elim: smc_prod_2_is_arrE[OF 𝔄 𝔅])
    from 𝔄 𝔅 g g' f f' show "op_smc (𝔄 ×SMC 𝔅)⦇Comp⦈⦇gg'ff'⦈ = 
      (op_smc 𝔄 ×SMC op_smc 𝔅)⦇Comp⦈⦇gg'ff'⦈"
      unfolding gg'ff'_def 
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_op_simps smc_prod_cs_simps
            cs_intro: smc_cs_intros smc_op_intros smc_prod_cs_intros
        )
  qed

  from 𝔄 𝔅 show 
    "smc_dg (op_smc (𝔄 ×SMC 𝔅)) = smc_dg (op_smc 𝔄 ×SMC op_smc 𝔅)"
    unfolding slicing_commute[symmetric]
    by (cs_concl cs_simp: dg_op_simps cs_intro: slicing_intros)

qed
  
end



subsection‹Projections for the product of two semicategories›


subsubsection‹Definition and elementary properties›


text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›

definition smcf_proj_fst :: "V ⇒ V ⇒ V" (‹πSMC.1›)
  where "πSMC.1 𝔄 𝔅 = smcf_proj (2ℕ) (λi. (i = 0 ? 𝔄 : 𝔅)) 0"
definition smcf_proj_snd :: "V ⇒ V ⇒ V" (‹πSMC.2›)
  where "πSMC.2 𝔄 𝔅 = smcf_proj (2ℕ) (λi. (i = 0 ? 𝔄 : 𝔅)) (1ℕ)"


text‹Slicing›

lemma smcf_dghm_smcf_proj_fst[slicing_commute]: 
  "πDG.1 (smc_dg 𝔄) (smc_dg 𝔅) = smcf_dghm (πSMC.1 𝔄 𝔅)"
  unfolding 
    smcf_proj_fst_def dghm_proj_fst_def slicing_commute[symmetric] if_distrib 
    ..

lemma smcf_dghm_smcf_proj_snd[slicing_commute]: 
  "πDG.2 (smc_dg 𝔄) (smc_dg 𝔅) = smcf_dghm (πSMC.2 𝔄 𝔅)"
  unfolding 
    smcf_proj_snd_def dghm_proj_snd_def slicing_commute[symmetric] if_distrib 
    ..

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)

lemmas_with 
  [
    where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.smc_digraph 𝔅.smc_digraph
  ]:
  smcf_proj_fst_ObjMap_app[smc_cs_simps] = dghm_proj_fst_ObjMap_app 
  and smcf_proj_snd_ObjMap_app[smc_cs_simps] = dghm_proj_snd_ObjMap_app
  and smcf_proj_fst_ArrMap_app[smc_cs_simps] = dghm_proj_fst_ArrMap_app
  and smcf_proj_snd_ArrMap_app[smc_cs_simps] = dghm_proj_snd_ArrMap_app

end


subsubsection‹
Domain and codomain of a projection of a product of two semicategories
›

lemma smcf_proj_fst_HomDom: "πSMC.1 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×SMC 𝔅"
  unfolding smcf_proj_fst_def smcf_proj_components smc_prod_2_def ..

lemma smcf_proj_fst_HomCod: "πSMC.1 𝔄 𝔅⦇HomCod⦈ = 𝔄"
  unfolding smcf_proj_fst_def smcf_proj_components smc_prod_2_def by simp
  
lemma smcf_proj_snd_HomDom: "πSMC.2 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×SMC 𝔅"
  unfolding smcf_proj_snd_def smcf_proj_components smc_prod_2_def ..

lemma smcf_proj_snd_HomCod: "πSMC.2 𝔄 𝔅⦇HomCod⦈ = 𝔅"
  unfolding smcf_proj_snd_def smcf_proj_components smc_prod_2_def by simp


subsubsection‹Projection of a product of two semicategories is a semifunctor›

context 
  fixes α 𝔄 𝔅
  assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation finite_psemicategory α ‹2ℕ› ‹if2 𝔄 𝔅›
  by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)

lemma smcf_proj_fst_is_semifunctor: 
  assumes "i ∈∘ I" 
  shows "πSMC.1 𝔄 𝔅 : 𝔄 ×SMC 𝔅 ↦↦SMCα 𝔄"
  by 
    (
      rule 
        psmc_smcf_proj_is_semifunctor[
          where i=0, simplified, folded smcf_proj_fst_def smc_prod_2_def
          ]
    )

lemma smcf_proj_fst_is_semifunctor'[smc_cs_intros]: 
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×SMC 𝔅" and "𝔇 = 𝔄"
  shows "πSMC.1 𝔄 𝔅 : ℭ ↦↦SMCα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule smcf_proj_fst_is_semifunctor)

lemma smcf_proj_snd_is_semifunctor: 
  assumes "i ∈∘ I" 
  shows "πSMC.2 𝔄 𝔅 : 𝔄 ×SMC 𝔅 ↦↦SMCα 𝔅"
  by 
    (
      rule 
        psmc_smcf_proj_is_semifunctor[
          where i=‹1ℕ›, simplified, folded smcf_proj_snd_def smc_prod_2_def
          ]
    )

lemma smcf_proj_snd_is_semifunctor'[smc_cs_intros]: 
  assumes "i ∈∘ I" and "ℭ = 𝔄 ×SMC 𝔅" and "𝔇 = 𝔅"
  shows "πSMC.2 𝔄 𝔅 : ℭ ↦↦SMCα 𝔇"
  using assms(1) unfolding assms(2,3) by (rule smcf_proj_snd_is_semifunctor)

end



subsection‹Product of three semicategories›
(*TODO: find a way to generalize to the product of n semicategories*)


subsubsection‹Definition and elementary properties.›

definition smc_prod_3 :: "V ⇒ V ⇒ V ⇒ V"
  ("(_ ×SMC3 _ ×SMC3 _)" [81, 81, 81] 80)
  where "𝔄 ×SMC3 𝔅 ×SMC3 ℭ = (∏SMCi∈∘3ℕ. if3 𝔄 𝔅 ℭ i)"


text‹Slicing.›

lemma smc_dg_smc_prod_3[slicing_commute]: 
  "smc_dg 𝔄 ×DG3 smc_dg 𝔅 ×DG3 smc_dg ℭ = smc_dg (𝔄 ×SMC3 𝔅 ×SMC3 ℭ)"
  unfolding smc_prod_3_def dg_prod_3_def slicing_commute[symmetric] if_distrib
  by (simp add: if_distrib[symmetric])

context
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "semicategory α 𝔄" 
    and 𝔅: "semicategory α 𝔅"
    and ℭ: "semicategory α ℭ"
begin

interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
interpretation ℭ: semicategory α ℭ by (rule ℭ)

lemmas_with 
  [
    where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅› and ℭ=‹smc_dg ℭ›, 
    unfolded slicing_simps slicing_commute, 
    OF 𝔄.smc_digraph 𝔅.smc_digraph ℭ.smc_digraph
  ]:
  smc_prod_3_ObjI = dg_prod_3_ObjI 
  and smc_prod_3_ObjI'[smc_prod_cs_intros] = dg_prod_3_ObjI'
  and smc_prod_3_ObjE = dg_prod_3_ObjE
  and smc_prod_3_ArrI = dg_prod_3_ArrI
  and smc_prod_3_ArrI'[smc_prod_cs_intros] = dg_prod_3_ArrI'
  and smc_prod_3_ArrE = dg_prod_3_ArrE
  and smc_prod_3_is_arrI = dg_prod_3_is_arrI
  and smc_prod_3_is_arrI'[smc_prod_cs_intros] = dg_prod_3_is_arrI'
  and smc_prod_3_is_arrE = dg_prod_3_is_arrE
  and smc_prod_3_Dom_vsv = dg_prod_3_Dom_vsv
  and smc_prod_3_Dom_vdomain[smc_cs_simps] = dg_prod_3_Dom_vdomain
  and smc_prod_3_Dom_app[smc_prod_cs_simps] = dg_prod_3_Dom_app
  and smc_prod_3_Dom_vrange = dg_prod_3_Dom_vrange
  and smc_prod_3_Cod_vsv = dg_prod_3_Cod_vsv
  and smc_prod_3_Cod_vdomain[smc_cs_simps] = dg_prod_3_Cod_vdomain
  and smc_prod_3_Cod_app[smc_prod_cs_simps] = dg_prod_3_Cod_app
  and smc_prod_3_Cod_vrange = dg_prod_3_Cod_vrange

end


subsubsection‹Product of three semicategories is a semicategory›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "semicategory α 𝔄" 
    and 𝔅: "semicategory α 𝔅"
    and ℭ: "semicategory α ℭ"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
interpretation ℭ: semicategory α ℭ by (rule ℭ)

lemma finite_psemicategory_smc_prod_3: 
  "finite_psemicategory α (3ℕ) (if3 𝔄 𝔅 ℭ)"
proof(intro finite_psemicategoryI psemicategory_baseI)
  from Axiom_of_Infinity show z1_in_Vset: "3ℕ ∈∘ Vset α" by blast
  show "semicategory α (if3 𝔄 𝔅 ℭ i)" if "i ∈∘ 3ℕ" for i
    by (auto simp: smc_cs_intros)
qed auto

interpretation finite_psemicategory α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_psemicategory_smc_prod_3 𝔄 𝔅)

lemma semicategory_smc_prod_3[smc_cs_intros]: 
  "semicategory α (𝔄 ×SMC3 𝔅 ×SMC3 ℭ)"
  unfolding smc_prod_3_def by (rule psmc_semicategory_smc_prod)

end


subsubsection‹Composition›

context 
  fixes α 𝔄 𝔅 ℭ
  assumes 𝔄: "semicategory α 𝔄" 
    and 𝔅: "semicategory α 𝔅"
    and ℭ: "semicategory α ℭ"
begin

interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])

interpretation finite_psemicategory α ‹3ℕ› ‹if3 𝔄 𝔅 ℭ›
  by (intro finite_psemicategory_smc_prod_3 𝔄 𝔅 ℭ)

lemma smc_prod_3_Comp_app[smc_prod_cs_simps]:
  assumes "[g, g', g'']∘ : [b, b', b'']∘ ↦𝔄 ×SMC3 𝔅 ×SMC3 ℭ [c, c', c'']∘" 
    and "[f, f', f'']∘ : [a, a', a'']∘ ↦𝔄 ×SMC3 𝔅 ×SMC3 ℭ [b, b', b'']∘"
  shows 
    "[g, g', g'']∘ ∘A𝔄 ×SMC3 𝔅 ×SMC3 ℭ [f, f', f'']∘ =
      [g ∘A𝔄 f, g' ∘A𝔅 f', g'' ∘Aℭ f'']∘"
proof-
  have 
    "[g, g', g'']∘ ∘A𝔄 ×SMC3 𝔅 ×SMC3 ℭ [f, f', f'']∘ =
      (λi∈∘3ℕ. [g, g', g'']∘⦇i⦈ ∘Aif3 𝔄 𝔅 ℭ i [f, f', f'']∘⦇i⦈)"
    by 
      (
        rule smc_prod_Comp_app[
          OF assms[unfolded smc_prod_3_def], folded smc_prod_3_def
          ]
      )
  also have 
    "(λi∈∘3ℕ. [g, g', g'']∘⦇i⦈ ∘Aif3 𝔄 𝔅 ℭ i [f, f', f'']∘⦇i⦈) = 
      [g ∘A𝔄 f, g' ∘A𝔅 f', g'' ∘Aℭ f'']∘"
  proof(rule vsv_eqI, unfold vdomain_VLambda)
    fix i assume "i ∈∘ 3ℕ"
    then consider ‹i = 0› | ‹i = 1ℕ› | ‹i = 2ℕ› unfolding three by auto 
    then show 
      "(λi∈∘3ℕ. [g, g', g'']∘⦇i⦈ ∘Aif3 𝔄 𝔅 ℭ i [f, f', f'']∘⦇i⦈)⦇i⦈ = 
        [g ∘A𝔄 f, g' ∘A𝔅 f', g'' ∘Aℭ f'']∘⦇i⦈"
      by cases (simp_all add: three nat_omega_simps)
  qed (auto simp: three nat_omega_simps)
  finally show ?thesis by simp
qed

end

text‹\newpage›

end

Theory CZH_SMC_Subsemicategory

(* Copyright 2021 (C) Mihails Milehins *)

section‹Subsemicategory›
theory CZH_SMC_Subsemicategory
  imports 
    CZH_DG_Subdigraph
    CZH_SMC_Semifunctor
begin



subsection‹Background›

named_theorems smc_sub_cs_intros
named_theorems smc_sub_bw_cs_intros
named_theorems smc_sub_fw_cs_intros
named_theorems smc_sub_bw_cs_simps



subsection‹Simple subsemicategory›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale subsemicategory = 
  sdg: semicategory α 𝔅 + dg: semicategory α ℭ for α 𝔅 ℭ + 
  assumes subsmc_subdigraph[slicing_intros]: "smc_dg 𝔅 ⊆DGα smc_dg ℭ" 
    and subsmc_Comp[smc_sub_fw_cs_intros]: 
      "⟦ g : b ↦𝔅 c; f : a ↦𝔅 b ⟧ ⟹ g ∘A𝔅 f = g ∘Aℭ f"

abbreviation is_subsemicategory ("(_/ ⊆SMCı _)" [51, 51] 50)
  where "𝔅 ⊆SMCα ℭ ≡ subsemicategory α 𝔅 ℭ"

lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_Comp


text‹Rules.›

lemma (in subsemicategory) subsemicategory_axioms'[smc_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆SMCα' ℭ"
  unfolding assms by (rule subsemicategory_axioms)

lemma (in subsemicategory) subsemicategory_axioms''[smc_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆SMCα' ℭ'"
  unfolding assms by (rule subsemicategory_axioms)

mk_ide rf subsemicategory_def[unfolded subsemicategory_axioms_def]
  |intro subsemicategoryI|
  |dest subsemicategoryD[dest]|
  |elim subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = subsemicategoryD(1,2)

lemma subsemicategoryI':
  assumes "semicategory α 𝔅"
    and "semicategory α ℭ"
    and "⋀a. a ∈∘ 𝔅⦇Obj⦈ ⟹ a ∈∘ ℭ⦇Obj⦈"
    and "⋀a b f. f : a ↦𝔅 b ⟹ f : a ↦ℭ b"
    and "⋀b c g a f. ⟦ g : b ↦𝔅 c; f : a ↦𝔅 b ⟧ ⟹
      g ∘A𝔅 f = g ∘Aℭ f"
  shows "𝔅 ⊆SMCα ℭ"
proof-
  interpret 𝔅: semicategory α 𝔅 by (rule assms(1))
  interpret ℭ: semicategory α ℭ by (rule assms(2))  
  show ?thesis
    by 
      (
        intro subsemicategoryI subdigraphI, 
        unfold slicing_simps; 
        (intro 𝔅.smc_digraph ℭ.smc_digraph assms)?
      )
qed


text‹Subsemicategory is a subdigraph.›

context subsemicategory
begin

interpretation subdg: subdigraph α ‹smc_dg 𝔅› ‹smc_dg ℭ›
  by (rule subsmc_subdigraph)

lemmas_with [unfolded slicing_simps]:
  subsmc_Obj_vsubset = subdg.subdg_Obj_vsubset
  and subsmc_is_arr_vsubset = subdg.subdg_is_arr_vsubset
  and subsmc_subdigraph_op_dg_op_dg = subdg.subdg_subdigraph_op_dg_op_dg
  and subsmc_objD = subdg.subdg_objD
  and subsmc_arrD = subdg.subdg_arrD
  and subsmc_dom_simp = subdg.subdg_dom_simp
  and subsmc_cod_simp = subdg.subdg_cod_simp
  and subsmc_is_arrD = subdg.subdg_is_arrD
  and subsmc_dghm_inc_op_dg_is_dghm = subdg.subdg_dghm_inc_op_dg_is_dghm
  and subsmc_op_dg_dghm_inc = subdg.subdg_op_dg_dghm_inc
  and subsmc_inc_is_ft_dghm_axioms = subdg.inc.is_ft_dghm_axioms

end

lemmas subsmc_subdigraph_op_dg_op_dg[intro] = 
  subsemicategory.subsmc_subdigraph_op_dg_op_dg

lemmas [smc_sub_fw_cs_intros] = 
  subsemicategory.subsmc_Obj_vsubset
  subsemicategory.subsmc_is_arr_vsubset
  subsemicategory.subsmc_objD
  subsemicategory.subsmc_arrD
  subsemicategory.subsmc_is_arrD

lemmas [smc_sub_bw_cs_simps] =
  subsemicategory.subsmc_dom_simp
  subsemicategory.subsmc_cod_simp


text‹The opposite subsemicategory.›

lemma (in subsemicategory) subsmc_subsemicategory_op_smc: 
  "op_smc 𝔅 ⊆SMCα op_smc ℭ"
proof(rule subsemicategoryI)
  fix g b c f a assume prems: "g : b ↦op_smc 𝔅 c" "f : a ↦op_smc 𝔅 b"
  then have "g : c ↦𝔅 b" and "f : b ↦𝔅 a" 
    by (simp_all add: smc_op_simps)
  with subsemicategory_axioms have g: "g : c ↦ℭ b" and f: "f : b ↦ℭ a" 
    by (cs_concl cs_intro: smc_sub_fw_cs_intros)+
  from dg.op_smc_Comp[OF this(2,1)] have "g ∘Aop_smc ℭ f = f ∘Aℭ g".
  with prems show "g ∘Aop_smc 𝔅 f = g ∘Aop_smc ℭ f"
    by (simp add: smc_op_simps subsmc_Comp)
qed 
  (
    auto 
      simp:
        smc_op_simps slicing_commute[symmetric] subsmc_subdigraph_op_dg_op_dg
      intro: smc_op_intros
  )

lemmas subsmc_subsemicategory_op_smc[intro, smc_op_intros] = 
  subsemicategory.subsmc_subsemicategory_op_smc


text‹Further rules.›

lemma (in subsemicategory) subsmc_Comp_simp:
  assumes "g : b ↦𝔅 c" and "f : a ↦𝔅 b"
  shows "g ∘A𝔅 f = g ∘Aℭ f"
  using assms subsmc_Comp by auto

lemmas [smc_sub_bw_cs_simps] = subsemicategory.subsmc_Comp_simp

lemma (in subsemicategory) subsmc_is_idem_arrD: 
  assumes "f : ↦ide𝔅 b" 
  shows "f : ↦ideℭ b"
  using assms subsemicategory_axioms
  by (intro is_idem_arrI; elim is_idem_arrE)
    (cs_concl cs_simp: smc_sub_bw_cs_simps[symmetric] cs_intro: smc_sub_fw_cs_intros)

lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_is_idem_arrD


subsubsection‹Subsemicategory relation is a partial order›

lemma subsmc_refl: 
  assumes "semicategory α 𝔄" 
  shows "𝔄 ⊆SMCα 𝔄"
proof-
  interpret semicategory α 𝔄 by (rule assms)
  show ?thesis 
    by (auto intro: smc_cs_intros slicing_intros subdg_refl subsemicategoryI)
qed

lemma subsmc_trans[trans]: 
  assumes "𝔄 ⊆SMCα 𝔅" and "𝔅 ⊆SMCα ℭ"
  shows "𝔄 ⊆SMCα ℭ"
proof-
  interpret 𝔄𝔅: subsemicategory α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅ℭ: subsemicategory α 𝔅 ℭ by (rule assms(2))
  show ?thesis 
  proof(rule subsemicategoryI)
    from 𝔄𝔅.subsmc_subdigraph 𝔅ℭ.subsmc_subdigraph 
    show "smc_dg 𝔄 ⊆DGα smc_dg ℭ" by (meson subdg_trans)
    show "g ∘A𝔄 f = g ∘Aℭ f" 
      if "g : b ↦𝔄 c" and "f : a ↦𝔄 b" for g b c f a
      by 
        (
          metis 
            that
            𝔄𝔅.subsmc_is_arr_vsubset 
            𝔄𝔅.subsmc_Comp_simp 
            𝔅ℭ.subsmc_Comp_simp
        )
  qed (auto intro: smc_cs_intros)
qed

lemma subsmc_antisym:
  assumes "𝔄 ⊆SMCα 𝔅" and "𝔅 ⊆SMCα 𝔄"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄𝔅: subsemicategory α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅𝔄: subsemicategory α 𝔅 𝔄 by (rule assms(2))
  show ?thesis
  proof(rule smc_eqI)
    from subdg_antisym[OF 𝔄𝔅.subsmc_subdigraph 𝔅𝔄.subsmc_subdigraph] have 
      "smc_dg 𝔄⦇Obj⦈ = smc_dg 𝔅⦇Obj⦈" "smc_dg 𝔄⦇Arr⦈ = smc_dg 𝔅⦇Arr⦈"
      by simp_all
    then show "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" and Arr: "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈" 
      unfolding slicing_simps by simp_all
    show "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" 
      by (rule vsv_eqI) (auto simp: smc_cs_simps 𝔄𝔅.subsmc_dom_simp Arr)
    show "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
      by (rule vsv_eqI) (auto simp: smc_cs_simps 𝔅𝔄.subsmc_cod_simp Arr)
    show "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
    proof(rule vsv_eqI)
      show "𝒟∘ (𝔄⦇Comp⦈) = 𝒟∘ (𝔅⦇Comp⦈)"
      proof(intro vsubset_antisym vsubsetI)
        fix gf assume "gf ∈∘ 𝒟∘ (𝔄⦇Comp⦈)"
        then obtain g f b c a 
          where gf_def: "gf = [g, f]∘" 
            and g: "g : b ↦𝔄 c" 
            and f: "f : a ↦𝔄 b"
          by (auto simp: 𝔄𝔅.sdg.smc_Comp_vdomain)
        from g f show "gf ∈∘ 𝒟∘ (𝔅⦇Comp⦈)"
          unfolding gf_def by (meson 𝔄𝔅.dg.smc_Comp_vdomainI 𝔄𝔅.subsmc_is_arrD)
      next
        fix gf assume "gf ∈∘ 𝒟∘ (𝔅⦇Comp⦈)"
        then obtain g f b c a 
          where gf_def: "gf = [g, f]∘" 
            and g: "g : b ↦𝔅 c" 
            and f: "f : a ↦𝔅 b"
          by (auto simp: 𝔄𝔅.dg.smc_Comp_vdomain)
        from g f show "gf ∈∘ 𝒟∘ (𝔄⦇Comp⦈)"
          unfolding gf_def by (meson 𝔄𝔅.sdg.smc_Comp_vdomainI 𝔅𝔄.subsmc_is_arrD)
      qed
      show "a ∈∘ 𝒟∘ (𝔄⦇Comp⦈) ⟹ 𝔄⦇Comp⦈⦇a⦈ = 𝔅⦇Comp⦈⦇a⦈" for a
        by (metis 𝔄𝔅.sdg.smc_Comp_vdomain 𝔄𝔅.subsmc_Comp_simp)
    qed auto
  qed (auto intro: smc_cs_intros)
qed



subsection‹Inclusion semifunctor›


subsubsection‹Definition and elementary properties›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

abbreviation (input) smcf_inc :: "V ⇒ V ⇒ V"
  where "smcf_inc ≡ dghm_inc"


text‹Slicing.›

lemma dghm_smcf_inc[slicing_commute]: 
  "dghm_inc (smc_dg 𝔅) (smc_dg ℭ) = smcf_dghm (smcf_inc 𝔅 ℭ)"
  unfolding 
    smcf_dghm_def dghm_inc_def smc_dg_def dg_field_simps dghm_field_simps 
  by (simp_all add: nat_omega_simps)


text‹Elementary properties.›

lemmas [smc_cs_simps] = 
  dghm_inc_ObjMap_app 
  dghm_inc_ArrMap_app


subsubsection‹Canonical inclusion semifunctor associated with a subsemicategory›

sublocale subsemicategory ⊆ inc: is_ft_semifunctor α 𝔅 ℭ ‹smcf_inc 𝔅 ℭ›
proof(rule is_ft_semifunctorI)
  show "smcf_inc 𝔅 ℭ : 𝔅 ↦↦SMCα ℭ"
  proof(rule is_semifunctorI)
    show "vfsequence (dghm_inc 𝔅 ℭ)" unfolding dghm_inc_def by auto
    show "vcard (dghm_inc 𝔅 ℭ) = 4ℕ"
      unfolding dghm_inc_def by (simp add: nat_omega_simps)
    fix g b c f a assume prems: "g : b ↦𝔅 c" "f : a ↦𝔅 b"
    then have "g ∘A𝔅 f : a ↦𝔅 c" by (simp add: smc_cs_intros)
    with subsemicategory_axioms prems have [simp]: 
      "vid_on (𝔅⦇Arr⦈)⦇g ∘A𝔅 f⦈ = g ∘Aℭ f" 
      by (auto simp: smc_sub_bw_cs_simps)
    from prems show "dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇g ∘A𝔅 f⦈ = 
      dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇g⦈ ∘Aℭ dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇f⦈"
      by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros smc_sub_fw_cs_intros)
  qed 
    (
      insert subsmc_inc_is_ft_dghm_axioms, 
      auto simp: slicing_commute[symmetric] dghm_inc_components smc_cs_intros
    )
qed (auto simp: slicing_commute[symmetric] subsmc_inc_is_ft_dghm_axioms)

lemmas (in subsemicategory) subsmc_smcf_inc_is_ft_semifunctor = 
  inc.is_ft_semifunctor_axioms


subsubsection‹Inclusion semifunctor for the opposite semicategories›

lemma (in subsemicategory) 
  subsemicategory_smcf_inc_op_smc_is_semifunctor[smc_sub_cs_intros]:
  "smcf_inc (op_smc 𝔅) (op_smc ℭ) : op_smc 𝔅 ↦↦SMC.faithfulα op_smc ℭ"
  by 
    (
      intro 
        subsemicategory.subsmc_smcf_inc_is_ft_semifunctor
        subsmc_subsemicategory_op_smc
    )

lemmas [smc_sub_cs_intros] = 
  subsemicategory.subsemicategory_smcf_inc_op_smc_is_semifunctor

lemma (in subsemicategory) subdg_op_smc_smcf_inc[smc_op_simps]: 
  "op_smcf (smcf_inc 𝔅 ℭ) = smcf_inc (op_smc 𝔅) (op_smc ℭ)"
  by 
    (
      rule smcf_eqI[of α ‹op_smc 𝔅› ‹op_smc ℭ›], 
      unfold smc_op_simps dghm_inc_components
    )
    (
      auto simp: 
        is_ft_semifunctorD
        subsemicategory_smcf_inc_op_smc_is_semifunctor
        inc.is_semifunctor_op
    )

lemmas [smc_op_simps] = subsemicategory.subdg_op_smc_smcf_inc



subsection‹Full subsemicategory›


text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›

locale fl_subsemicategory = subsemicategory +
  assumes fl_subsemicategory_fl_subdigraph: "smc_dg 𝔅 ⊆DG.fullα smc_dg ℭ"

abbreviation is_fl_subsemicategory ("(_/ ⊆SMC.fullı _)" [51, 51] 50)
  where "𝔅 ⊆SMC.fullα ℭ ≡ fl_subsemicategory α 𝔅 ℭ"


text‹Rules.›

lemma (in fl_subsemicategory) fl_subsemicategory_axioms'[smc_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆SMC.fullα' ℭ"
  unfolding assms by (rule fl_subsemicategory_axioms)

lemma (in fl_subsemicategory) fl_subsemicategory_axioms''[smc_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆SMC.fullα' ℭ'"
  unfolding assms by (rule fl_subsemicategory_axioms)

mk_ide rf fl_subsemicategory_def[unfolded fl_subsemicategory_axioms_def]
  |intro fl_subsemicategoryI|
  |dest fl_subsemicategoryD[dest]|
  |elim fl_subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = fl_subsemicategoryD(1)


text‹Full subsemicategory.›

sublocale fl_subsemicategory ⊆ inc: is_fl_semifunctor α 𝔅 ℭ ‹smcf_inc 𝔅 ℭ›
  using fl_subsemicategory_fl_subdigraph inc.is_semifunctor_axioms
  by (intro is_fl_semifunctorI) (auto simp: slicing_commute[symmetric])



subsection‹Wide subsemicategory›


subsubsection‹Definition and elementary properties›


text‹
See \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
›

locale wide_subsemicategory = subsemicategory +
  assumes wide_subsmc_wide_subdigraph: "smc_dg 𝔅 ⊆DG.wideα smc_dg ℭ"

abbreviation is_wide_subsemicategory ("(_/ ⊆SMC.wideı _)" [51, 51] 50)
  where "𝔅 ⊆SMC.wideα ℭ ≡ wide_subsemicategory α 𝔅 ℭ"


text‹Rules.›

lemma (in wide_subsemicategory) wide_subsemicategory_axioms'[smc_cs_intros]:
  assumes "α' = α" and "𝔅' = 𝔅"
  shows "𝔅' ⊆SMC.wideα' ℭ"
  unfolding assms by (rule wide_subsemicategory_axioms)

lemma (in wide_subsemicategory) wide_subsemicategory_axioms''[smc_cs_intros]:
  assumes "α' = α" and "ℭ' = ℭ"
  shows "𝔅 ⊆SMC.wideα' ℭ'"
  unfolding assms by (rule wide_subsemicategory_axioms)

mk_ide rf wide_subsemicategory_def[unfolded wide_subsemicategory_axioms_def]
  |intro wide_subsemicategoryI|
  |dest wide_subsemicategoryD[dest]|
  |elim wide_subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = wide_subsemicategoryD(1)


text‹Wide subsemicategory is wide subdigraph.›

context wide_subsemicategory
begin

interpretation wide_subdg: wide_subdigraph α ‹smc_dg 𝔅› ‹smc_dg ℭ›
  by (rule wide_subsmc_wide_subdigraph)

lemmas_with [unfolded slicing_simps]:
  wide_subsmc_Obj[dg_sub_bw_cs_intros] = wide_subdg.wide_subdg_Obj
  and wide_subsmc_obj_eq[dg_sub_bw_cs_simps] = wide_subdg.wide_subdg_obj_eq

end

lemmas [dg_sub_bw_cs_intros] = wide_subsemicategory.wide_subsmc_Obj
lemmas [dg_sub_bw_cs_simps] = wide_subsemicategory.wide_subsmc_obj_eq


subsubsection‹The wide subsemicategory relation is a partial order›

lemma wide_subsmc_refl: 
  assumes "semicategory α 𝔄" 
  shows "𝔄 ⊆SMC.wideα 𝔄"
proof-
  interpret semicategory α 𝔄 by (rule assms)
  show ?thesis 
    by 
      (
        auto intro: 
          assms
          slicing_intros 
          wide_subdg_refl 
          wide_subsemicategoryI 
          subsmc_refl 
      )
qed

lemma wide_subsmc_trans[trans]:
  assumes "𝔄 ⊆SMC.wideα 𝔅" and "𝔅 ⊆SMC.wideα ℭ"
  shows "𝔄 ⊆SMC.wideα ℭ"
proof-
  interpret 𝔄𝔅: wide_subsemicategory α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅ℭ: wide_subsemicategory α 𝔅 ℭ by (rule assms(2))
  show ?thesis
    by 
      (
        intro 
          wide_subsemicategoryI 
          subsmc_trans[
            OF 𝔄𝔅.subsemicategory_axioms 𝔅ℭ.subsemicategory_axioms
            ], 
        rule wide_subdg_trans, 
        rule 𝔄𝔅.wide_subsmc_wide_subdigraph, 
        rule 𝔅ℭ.wide_subsmc_wide_subdigraph
     )
qed

lemma wide_subsmc_antisym:
  assumes "𝔄 ⊆SMC.wideα 𝔅" and "𝔅 ⊆SMC.wideα 𝔄"
  shows "𝔄 = 𝔅"
proof-
  interpret 𝔄𝔅: wide_subsemicategory α 𝔄 𝔅 by (rule assms(1))
  interpret 𝔅𝔄: wide_subsemicategory α 𝔅 𝔄 by (rule assms(2))
  show ?thesis 
    by 
      (
        rule subsmc_antisym[
          OF 𝔄𝔅.subsemicategory_axioms 𝔅𝔄.subsemicategory_axioms
          ]
      )
qed

text‹\newpage›

end

Theory CZH_SMC_Simple

(* Copyright 2021 (C) Mihails Milehins *)

section‹Simple semicategories›
theory CZH_SMC_Simple
  imports 
    CZH_DG_Simple
    CZH_SMC_Semifunctor
begin



subsection‹Background›


text‹
The section presents a variety of simple semicategories, such as the empty
semicategory ‹0› and a semicategory with one object and one arrow ‹1›.
All of the entities presented in this section are generalizations of certain
simple categories, whose definitions can be found 
in \cite{mac_lane_categories_2010}.
›



subsection‹Empty semicategory ‹0››


subsubsection‹Definition and elementary properties›


text‹See Chapter I-2 in \cite{mac_lane_categories_2010}.›

definition smc_0 :: "V"
  where "smc_0 = [0, 0, 0, 0, 0]∘"


text‹Components.›

lemma smc_0_components:
  shows "smc_0⦇Obj⦈ = 0"
    and "smc_0⦇Arr⦈ = 0"
    and "smc_0⦇Dom⦈ = 0"
    and "smc_0⦇Cod⦈ = 0"
    and "smc_0⦇Comp⦈ = 0"
  unfolding smc_0_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma dg_smc_0: "smc_dg smc_0 = dg_0"
  unfolding smc_dg_def smc_0_def dg_0_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with (in 𝒵) [folded dg_smc_0, unfolded slicing_simps]: 
  smc_0_is_arr_iff = dg_0_is_arr_iff


subsubsection‹‹0› is a semicategory›

lemma (in 𝒵) semicategory_smc_0: "semicategory α smc_0"
proof(intro semicategoryI)
  show "vfsequence smc_0" unfolding smc_0_def by (simp add: nat_omega_simps)
  show "vcard smc_0 = 5ℕ" unfolding smc_0_def by (simp add: nat_omega_simps)
  show "digraph α (smc_dg smc_0)"
    by (simp add: dg_smc_0 𝒵.digraph_dg_0 𝒵_axioms)
qed (auto simp: smc_0_components smc_0_is_arr_iff)


subsubsection‹A semicategory without objects is empty›

lemma (in semicategory) smc_smc_0_if_Obj_0:
  assumes "ℭ⦇Obj⦈ = 0"
  shows "ℭ = smc_0"
  by (rule smc_eqI[of α])
    (
      auto simp:
        smc_cs_intros
        assms
        semicategory_smc_0 
        smc_0_components 
        smc_Arr_vempty_if_Obj_vempty 
        smc_Cod_vempty_if_Arr_vempty 
        smc_Dom_vempty_if_Arr_vempty
        smc_Comp_vempty_if_Arr_vempty
    )



subsection‹Empty semifunctor›


text‹
An empty semifunctor is defined as a semifunctor between an
empty semicategory and an arbitrary semicategory.
›


subsubsection‹Definition and elementary properties›

definition smcf_0 :: "V ⇒ V"
  where "smcf_0 𝔄 = [0, 0, smc_0, 𝔄]∘"


text‹Components.›

lemma smcf_0_components:
  shows "smcf_0 𝔄⦇ObjMap⦈ = 0"
    and "smcf_0 𝔄⦇ArrMap⦈ = 0"
    and "smcf_0 𝔄⦇HomDom⦈ = smc_0"
    and "smcf_0 𝔄⦇HomCod⦈ = 𝔄"
  unfolding smcf_0_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_smcf_0: "smcf_dghm (smcf_0 𝔄) = dghm_0 (smc_dg 𝔄)"
  unfolding 
    smcf_dghm_def smcf_0_def dg_0_def smc_0_def dghm_0_def smc_dg_def 
    dg_field_simps dghm_field_simps 
  by (simp add: nat_omega_simps)


subsubsection‹Empty semifunctor is a faithful semifunctor›

lemma (in 𝒵) smcf_0_is_semifunctor: 
  assumes "semicategory α 𝔄"
  shows "smcf_0 𝔄 : smc_0 ↦↦SMC.faithfulα 𝔄"
proof(rule is_ft_semifunctorI)
  show "smcf_0 𝔄 : smc_0 ↦↦SMCα 𝔄"
  proof(rule is_semifunctorI, unfold dg_smc_0 smcf_dghm_smcf_0)
    show "vfsequence (smcf_0 𝔄)" unfolding smcf_0_def by simp
    show "vcard (smcf_0 𝔄) = 4ℕ"
      unfolding smcf_0_def by (simp add: nat_omega_simps)
    show "dghm_0 (smc_dg 𝔄) : dg_0 ↦↦DGα smc_dg 𝔄"
      by 
        (
          simp add: 
            assms 
            dghm_0_is_dghm 
            is_ft_dghm.axioms(1) 
            semicategory.smc_digraph
        )
  qed (auto simp: assms semicategory_smc_0 smcf_0_components smc_0_is_arr_iff)
  show "smcf_dghm (smcf_0 𝔄) : smc_dg smc_0 ↦↦DG.faithfulα smc_dg 𝔄"
    by 
      (
        auto simp: 
          assms 
          𝒵.dghm_0_is_dghm
          𝒵_axioms 
          dg_smc_0 
          semicategory.smc_digraph 
          smcf_dghm_smcf_0
      )
qed



subsection‹‹10›: semicategory with one object and no arrows›


subsubsection‹Definition and elementary properties›

definition smc_10 :: "V ⇒ V"
  where "smc_10 𝔞 = [set {𝔞}, 0, 0, 0, 0]∘"


text‹Components.›

lemma smc_10_components:
  shows "smc_10 𝔞⦇Obj⦈ = set {𝔞}"
    and "smc_10 𝔞⦇Arr⦈ = 0"
    and "smc_10 𝔞⦇Dom⦈ = 0"
    and "smc_10 𝔞⦇Cod⦈ = 0"
    and "smc_10 𝔞⦇Comp⦈ = 0"
  unfolding smc_10_def dg_field_simps by (auto simp: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_smc_10: "smc_dg (smc_10 𝔞) = (dg_10 𝔞)"
  unfolding smc_dg_def smc_10_def dg_10_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with (in 𝒵) [folded smc_dg_smc_10, unfolded slicing_simps]: 
  smc_10_is_arr_iff = dg_10_is_arr_iff


subsubsection‹‹10› is a semicategory›

lemma (in 𝒵) semicategory_smc_10: 
  assumes "𝔞 ∈∘ Vset α" 
  shows "semicategory α (smc_10 𝔞)"
proof(intro semicategoryI)
  show "vfsequence (smc_10 𝔞)" 
    unfolding smc_10_def by (simp add: nat_omega_simps)
  show "vcard (smc_10 𝔞) = 5ℕ" 
    unfolding smc_10_def by (simp add: nat_omega_simps)
  show "digraph α (smc_dg (smc_10 𝔞))"
    unfolding smc_dg_smc_10 by (rule digraph_dg_10[OF assms])
qed (auto simp: smc_10_components smc_10_is_arr_iff vsubset_vsingleton_leftI)


subsubsection‹Arrow with a domain and a codomain›

lemma smc_10_is_arr_iff: "𝔉 : 𝔄 ↦smc_10 𝔞 𝔅 ⟷ False"
  unfolding is_arr_def smc_10_components by simp



subsection‹‹1›: semicategory with one object and one arrow›


subsubsection‹Definition and elementary properties›

definition smc_1 :: "V ⇒ V ⇒ V"
  where "smc_1 𝔞 𝔣 = 
    [set {𝔞}, set {𝔣}, set {⟨𝔣, 𝔞⟩}, set {⟨𝔣, 𝔞⟩}, set {⟨[𝔣, 𝔣]∘, 𝔣⟩}]∘"


text‹Components.›

lemma smc_1_components:
  shows "smc_1 𝔞 𝔣⦇Obj⦈ = set {𝔞}"
    and "smc_1 𝔞 𝔣⦇Arr⦈ = set {𝔣}"
    and "smc_1 𝔞 𝔣⦇Dom⦈ = set {⟨𝔣, 𝔞⟩}"
    and "smc_1 𝔞 𝔣⦇Cod⦈ = set {⟨𝔣, 𝔞⟩}"
    and "smc_1 𝔞 𝔣⦇Comp⦈ = set {⟨[𝔣, 𝔣]∘, 𝔣⟩}"
  unfolding smc_1_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma dg_smc_1: "smc_dg (smc_1 𝔞 𝔣) = dg_1 𝔞 𝔣"
  unfolding smc_dg_def smc_1_def dg_1_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with [folded dg_smc_1, unfolded slicing_simps]: 
  smc_1_is_arrI = dg_1_is_arrI
  and smc_1_is_arrD = dg_1_is_arrD
  and smc_1_is_arrE = dg_1_is_arrE
  and smc_1_is_arr_iff = dg_1_is_arr_iff


subsubsection‹Composition›

lemma smc_1_Comp_app[simp]: "𝔣 ∘Asmc_1 𝔞 𝔣 𝔣 = 𝔣"
  unfolding smc_1_components by simp


subsubsection‹‹1› is a semicategory›

lemma (in 𝒵) semicategory_smc_1: 
  assumes "𝔞 ∈∘ Vset α" and "𝔣 ∈∘ Vset α" 
  shows "semicategory α (smc_1 𝔞 𝔣)"
proof(intro semicategoryI, unfold dg_smc_1)
  show "vfsequence (smc_1 𝔞 𝔣)"
    unfolding smc_1_def by (simp add: nat_omega_simps)
  show "vcard (smc_1 𝔞 𝔣) = 5ℕ"
    unfolding smc_1_def by (simp add: nat_omega_simps)
qed 
  (
    auto simp: 
      assms
      digraph_dg_1 
      smc_1_is_arr_iff 
      smc_1_components  
      vsubset_vsingleton_leftI
  )

text‹\newpage›

end

Theory CZH_SMC_GRPH

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹GRPH› as a semicategory›
theory CZH_SMC_GRPH
  imports 
    CZH_DG_Simple
    CZH_DG_GRPH
    CZH_SMC_Small_Semicategory
begin



subsection‹Background›

text‹
The methodology for the exposition 
of ‹GRPH› as a semicategory is analogous to the 
one used in the previous chapter
for the exposition of ‹GRPH› as a digraph.
›

named_theorems smc_GRPH_cs_simps
named_theorems smc_GRPH_cs_intros



subsection‹Definition and elementary properties›

definition smc_GRPH :: "V ⇒ V"
  where "smc_GRPH α =
    [
      set {ℭ. digraph α ℭ}, 
      all_dghms α, 
      (λ𝔉∈∘all_dghms α. 𝔉⦇HomDom⦈), 
      (λ𝔉∈∘all_dghms α. 𝔉⦇HomCod⦈),
      (λ𝔊𝔉∈∘composable_arrs (dg_GRPH α). 𝔊𝔉⦇0⦈ ∘DGHM 𝔊𝔉⦇1ℕ⦈)
    ]∘"


text‹Components.›

lemma smc_GRPH_components:
  shows "smc_GRPH α⦇Obj⦈ = set {ℭ. digraph α ℭ}"
    and "smc_GRPH α⦇Arr⦈ = all_dghms α"
    and "smc_GRPH α⦇Dom⦈ = (λ𝔉∈∘all_dghms α. 𝔉⦇HomDom⦈)"
    and "smc_GRPH α⦇Cod⦈ = (λ𝔉∈∘all_dghms α. 𝔉⦇HomCod⦈)"
    and "smc_GRPH α⦇Comp⦈ = 
      (λ𝔊𝔉∈∘composable_arrs (dg_GRPH α). 𝔊𝔉⦇0⦈ ∘DGHM 𝔊𝔉⦇1ℕ⦈)"
  unfolding smc_GRPH_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_GRPH: "smc_dg (smc_GRPH α) = dg_GRPH α"
proof(rule vsv_eqI)
  show "vsv (smc_dg (smc_GRPH α))" unfolding smc_dg_def by auto
  show "vsv (dg_GRPH α)" unfolding dg_GRPH_def by auto
  have dom_lhs: "𝒟∘ (smc_dg (smc_GRPH α)) = 4ℕ" 
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (dg_GRPH α) = 4ℕ"
    unfolding dg_GRPH_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smc_dg (smc_GRPH α)) = 𝒟∘ (dg_GRPH α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smc_dg (smc_GRPH α)) ⟹ smc_dg (smc_GRPH α)⦇a⦈ = dg_GRPH α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral, 
        unfold smc_dg_def dg_field_simps smc_GRPH_def dg_GRPH_def
      )
      (auto simp: nat_omega_simps)
qed

lemmas_with [folded smc_dg_GRPH, unfolded slicing_simps]: 
  smc_GRPH_ObjI = dg_GRPH_ObjI
  and smc_GRPH_ObjD = dg_GRPH_ObjD
  and smc_GRPH_ObjE = dg_GRPH_ObjE
  and smc_GRPH_Obj_iff[smc_GRPH_cs_simps] = dg_GRPH_Obj_iff  
  and smc_GRPH_Dom_app[smc_GRPH_cs_simps] = dg_GRPH_Dom_app
  and smc_GRPH_Cod_app[smc_GRPH_cs_simps] = dg_GRPH_Cod_app
  and smc_GRPH_is_arrI = dg_GRPH_is_arrI
  and smc_GRPH_is_arrD = dg_GRPH_is_arrD
  and smc_GRPH_is_arrE = dg_GRPH_is_arrE
  and smc_GRPH_is_arr_iff[smc_GRPH_cs_simps] = dg_GRPH_is_arr_iff



subsection‹Composable arrows›

lemma smc_GRPH_composable_arrs_dg_GRPH: 
  "composable_arrs (dg_GRPH α) = composable_arrs (smc_GRPH α)"
  unfolding composable_arrs_def smc_dg_GRPH[symmetric] slicing_simps by auto

lemma smc_GRPH_Comp: 
  "smc_GRPH α⦇Comp⦈ = (λ𝔊𝔉∈∘composable_arrs (smc_GRPH α). 𝔊𝔉⦇0⦈ ∘DGHM 𝔊𝔉⦇1ℕ⦈)"
  unfolding smc_GRPH_components smc_GRPH_composable_arrs_dg_GRPH ..



subsection‹Composition›

lemma smc_GRPH_Comp_app:
  assumes "𝔊 : 𝔅 ↦smc_GRPH α ℭ" and "𝔉 : 𝔄 ↦smc_GRPH α 𝔅"
  shows "𝔊 ∘Asmc_GRPH α 𝔉 = 𝔊 ∘DGHM 𝔉"
proof-
  from assms have "[𝔊, 𝔉]∘ ∈∘ composable_arrs (smc_GRPH α)" 
    by (auto intro: smc_cs_intros)
  then show "𝔊 ∘Asmc_GRPH α 𝔉 = 𝔊 ∘DGHM 𝔉"
    unfolding smc_GRPH_Comp by (simp add: nat_omega_simps)
qed 

lemma smc_GRPH_Comp_vdomain:
  "𝒟∘ (smc_GRPH α⦇Comp⦈) = composable_arrs (smc_GRPH α)" 
  unfolding smc_GRPH_Comp by auto                      



subsection‹‹GRPH› is a semicategory›

lemma (in 𝒵) tiny_semicategory_smc_GRPH:
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_semicategory β (smc_GRPH α)"
proof(intro tiny_semicategoryI, unfold smc_GRPH_is_arr_iff)
  show "vfsequence (smc_GRPH α)" unfolding smc_GRPH_def by auto
  show "vcard (smc_GRPH α) = 5ℕ"
    unfolding smc_GRPH_def by (simp add: nat_omega_simps)
  show "(gf ∈∘ 𝒟∘ (smc_GRPH α⦇Comp⦈)) ⟷
    (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦↦DGα c ∧ f : a ↦↦DGα b)"
    for gf
    unfolding smc_GRPH_Comp_vdomain
  proof
    show "gf ∈∘ composable_arrs (smc_GRPH α) ⟹ 
      ∃g f b c a. gf = [g, f]∘ ∧ g : b ↦↦DGα c ∧ f : a ↦↦DGα b"
      by (elim composable_arrsE) (auto simp: smc_GRPH_is_arr_iff)
  next
    assume "∃g f b c a. gf = [g, f]∘ ∧ g : b ↦↦DGα c ∧ f : a ↦↦DGα b"
    with smc_GRPH_is_arr_iff show "gf ∈∘ composable_arrs (smc_GRPH α)"
      unfolding smc_GRPH_Comp_vdomain by (auto intro: smc_cs_intros)
  qed
  show "⟦ g : b ↦↦DGα c; f : a ↦↦DGα b ⟧ ⟹ 
    g ∘Asmc_GRPH α f : a ↦↦DGα c"
    for g b c f a
    by (auto simp: smc_GRPH_Comp_app dghm_comp_is_dghm smc_GRPH_cs_simps)
  fix h c d g b f a
  assume "h : c ↦↦DGα d" "g : b ↦↦DGα c" "f : a ↦↦DGα b"
  moreover then have "g ∘DGHM f : a ↦↦DGα c" "h ∘DGHM g : b ↦↦DGα d" 
    by (auto simp: dghm_comp_is_dghm smc_GRPH_cs_simps)
  ultimately show 
    "h ∘Asmc_GRPH α g ∘Asmc_GRPH α f =
      h ∘Asmc_GRPH α (g ∘Asmc_GRPH α f)"
    by (simp add: smc_GRPH_is_arr_iff smc_GRPH_Comp_app dghm_comp_assoc)
qed (simp_all add: assms smc_dg_GRPH tiny_digraph_dg_GRPH smc_GRPH_components)



subsection‹Initial object›

lemma (in 𝒵) smc_GRPH_obj_initialI: "obj_initial (smc_GRPH α) dg_0"
  unfolding obj_initial_def
proof
  (
    intro obj_terminalI, 
    unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
  )
  show "digraph α dg_0" by (intro digraph_dg_0)
  fix 𝔄 assume "digraph α 𝔄"
  then interpret digraph α 𝔄 .
  show "∃!f. f : dg_0 ↦↦DGα 𝔄"
  proof
    show dghm_0: "dghm_0 𝔄 : dg_0 ↦↦DGα 𝔄"
      by (simp add: dghm_0_is_dghm digraph_axioms is_ft_dghm.axioms(1))
    fix 𝔉 assume prems: "𝔉 : dg_0 ↦↦DGα 𝔄" 
    then interpret 𝔉: is_dghm α dg_0 𝔄 𝔉 .
    show "𝔉 = dghm_0 𝔄"
    proof(rule dghm_eqI)
      from dghm_0 show "dghm_0 𝔄 : dg_0 ↦↦DGα 𝔄"
        unfolding smc_GRPH_is_arr_iff by simp
      have [simp]: "𝒟∘ (𝔉⦇ObjMap⦈) = 0" by (simp add: dg_cs_simps dg_0_components)
      with 𝔉.ObjMap.vdomain_vrange_is_vempty show "𝔉⦇ObjMap⦈ = dghm_0 𝔄⦇ObjMap⦈"
        by 
          (
            auto 
              intro: 𝔉.ObjMap.vsv_vrange_vempty 
              simp: dg_0_components dghm_0_components
          )
      from 𝔉.dghm_ObjMap_vdomain have "𝒟∘ (𝔉⦇ArrMap⦈) = 0" 
        by 
          (
            auto
              simp: 𝔉.dghm_ArrMap_vdomain 
              intro: 𝔉.HomDom.dg_Arr_vempty_if_Obj_vempty
          )
      then show "𝔉⦇ArrMap⦈ = dghm_0 𝔄⦇ArrMap⦈"
        by 
          (
            metis 
              𝔉.ArrMap.vsv_axioms 
              dghm_0_components(2) 
              vsv.vdomain_vrange_is_vempty 
              vsv.vsv_vrange_vempty
          )
    qed (auto simp: dghm_0_components prems)
  qed
qed

lemma (in 𝒵) smc_GRPH_obj_initialD:
  assumes "obj_initial (smc_GRPH α) 𝔄"
  shows "𝔄 = dg_0" 
  using assms unfolding obj_initial_def
proof
  (
    elim obj_terminalE,
    unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
  )
  assume prems: "digraph α 𝔄" "digraph α 𝔅 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦DGα 𝔅" for 𝔅
  from prems(2)[OF digraph_dg_0] obtain 𝔉 where 𝔉: "𝔉 : 𝔄 ↦↦DGα dg_0" 
    by meson
  interpret 𝔉: is_dghm α 𝔄 dg_0 𝔉 by (rule 𝔉) 
  have "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 0"
    unfolding dg_0_components(1)[symmetric] by (simp add: 𝔉.dghm_ObjMap_vrange)
  then have "𝔉⦇ObjMap⦈ = 0" by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
  with 𝔉.dghm_ObjMap_vdomain have Obj[simp]: "𝔄⦇Obj⦈ = 0" by auto
  have "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ 0"
    unfolding dg_0_components(2)[symmetric]
    by (simp add: 𝔉.dghm_ArrMap_vrange)
  then have "𝔉⦇ArrMap⦈ = 0" by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
  with 𝔉.dghm_ArrMap_vdomain have Arr[simp]: "𝔄⦇Arr⦈ = 0" by auto
  from Arr 𝔉.HomDom.dg_Dom_vempty_if_Arr_vempty have [simp]: "𝔄⦇Dom⦈ = []∘" 
    by auto
  from Arr 𝔉.HomDom.dg_Cod_vempty_if_Arr_vempty have [simp]: "𝔄⦇Cod⦈ = []∘"
    by auto
  show "𝔄 = dg_0"
    by (rule dg_eqI[of α]) (simp_all add: prems(1) dg_0_components digraph_dg_0)
qed

lemma (in 𝒵) smc_GRPH_obj_initialE:
  assumes "obj_initial (smc_GRPH α) 𝔄"
  obtains "𝔄 = dg_0" 
  using assms by (auto dest: smc_GRPH_obj_initialD)

lemma (in 𝒵) smc_GRPH_obj_initial_iff[smc_GRPH_cs_simps]: 
  "obj_initial (smc_GRPH α) 𝔄 ⟷ 𝔄 = dg_0"
  using smc_GRPH_obj_initialI smc_GRPH_obj_initialD by auto



subsection‹Terminal object›

lemma (in 𝒵) smc_GRPH_obj_terminalI[smc_GRPH_cs_intros]: 
  assumes "a ∈∘ Vset α" and "f ∈∘ Vset α"
  shows "obj_terminal (smc_GRPH α) (dg_1 a f)"
proof
  (
    intro obj_terminalI, 
    unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
  )
  fix 𝔄 assume "digraph α 𝔄"
  then interpret digraph α 𝔄 .
  show "∃!𝔉'. 𝔉' : 𝔄 ↦↦DGα dg_1 a f"
  proof
    show dghm_1: "dghm_const 𝔄 (dg_1 a f) a f : 𝔄 ↦↦DGα dg_1 a f"
      by 
        (
          auto simp:
            assms 
            dg_1_is_arr_iff 
            dghm_const_is_dghm 
            digraph_axioms' 
            digraph_dg_1
        )
    fix 𝔉' assume prems: "𝔉' : 𝔄 ↦↦DGα dg_1 a f"
    then interpret 𝔉': is_dghm α 𝔄 ‹dg_1 a f› 𝔉' .
    show "𝔉' = dghm_const 𝔄 (dg_1 a f) a f"
    proof(rule dghm_eqI, unfold dghm_const_components)
      show "dghm_const 𝔄 (dg_1 a f) a f : 𝔄 ↦↦DGα dg_1 a f" by (rule dghm_1)
      show "𝔉'⦇ObjMap⦈ = vconst_on (𝔄⦇Obj⦈) a"
      proof(cases‹𝔄⦇Obj⦈ = 0›)
        case True
        then have "𝔉'⦇ObjMap⦈ = 0"
          by 
            (
              simp add: 
                𝔉'.ObjMap.vdomain_vrange_is_vempty 
                𝔉'.dghm_ObjMap_vsv 
                vsv.vsv_vrange_vempty
            )
        with True show ?thesis by simp
      next
        case False
        then have "𝒟∘ (𝔉'⦇ObjMap⦈) ≠ 0" by (auto simp: 𝔉'.dghm_ObjMap_vdomain)
        with False have "ℛ∘ (𝔉'⦇ObjMap⦈) ≠ 0" by fastforce
        moreover from 𝔉'.dghm_ObjMap_vrange have "ℛ∘ (𝔉'⦇ObjMap⦈) ⊆∘ set {a}"
          by (simp add: dg_1_components)
        ultimately have "ℛ∘ (𝔉'⦇ObjMap⦈) = set {a}" by auto
        with 𝔉'.dghm_ObjMap_vdomain show ?thesis
          by (intro vsv.vsv_is_vconst_onI) blast+
      qed
      show "𝔉'⦇ArrMap⦈ = vconst_on (𝔄⦇Arr⦈) f"
      proof(cases‹𝔄⦇Arr⦈ = 0›)
        case True
        then have "𝔉'⦇ArrMap⦈ = 0"
          by 
            (
              simp add: 
                𝔉'.ArrMap.vdomain_vrange_is_vempty 
                𝔉'.dghm_ArrMap_vsv 
                vsv.vsv_vrange_vempty
            )
        with True show ?thesis by simp
      next
        case False
        then have "𝒟∘ (𝔉'⦇ArrMap⦈) ≠ 0" by (auto simp: 𝔉'.dghm_ArrMap_vdomain)
        with False have "ℛ∘ (𝔉'⦇ArrMap⦈) ≠ 0" 
          by (force simp: 𝔉'.ArrMap.vdomain_vrange_is_vempty)
        moreover from 𝔉'.dghm_ArrMap_vrange have "ℛ∘ (𝔉'⦇ArrMap⦈) ⊆∘ set {f}"
          by (simp add: dg_1_components)
        ultimately have "ℛ∘ (𝔉'⦇ArrMap⦈) = set {f}" by auto
        then show ?thesis 
          by (intro vsv.vsv_is_vconst_onI) (auto simp: 𝔉'.dghm_ArrMap_vdomain)
      qed
    qed (auto intro: prems)
  qed 
qed (simp add: assms digraph_dg_1)

lemma (in 𝒵) smc_GRPH_obj_terminalE: 
  assumes "obj_terminal (smc_GRPH α) 𝔅"
  obtains a f where "a ∈∘ Vset α" and "f ∈∘ Vset α" and "𝔅 = dg_1 a f"
  using assms
proof
  (
    elim obj_terminalE; 
    unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
  )  
  assume prems: "digraph α 𝔅" "digraph α 𝔄 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦DGα 𝔅" for 𝔄
  then interpret 𝔅: digraph α 𝔅 by simp
  obtain a where 𝔅_Obj: "𝔅⦇Obj⦈ = set {a}" and a: "a ∈∘ Vset α"
  proof-
    have dg_10: "digraph α (dg_10 0)" by (rule digraph_dg_10) auto
    from prems(2)[OF dg_10] obtain 𝔉 
      where 𝔉: "𝔉 : dg_10 0 ↦↦DGα 𝔅" 
        and 𝔊𝔉: "𝔊 : dg_10 0 ↦↦DGα 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
      by fastforce
    interpret 𝔉: is_dghm α ‹dg_10 0› 𝔅 𝔉 by (rule 𝔉)
    have "𝒟∘ (𝔉⦇ObjMap⦈) = set {0}" 
      by (simp add: dg_cs_simps dg_10_components)
    then obtain a where vrange_𝔉[simp]: "ℛ∘ (𝔉⦇ObjMap⦈) = set {a}"
      by 
        (
          auto 
            simp: dg_cs_simps 
            intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton
        )
    with 𝔅.dg_Obj_vsubset_Vset 𝔉.dghm_ObjMap_vrange have [simp]: "a ∈∘ Vset α"
      by auto
    from 𝔉.dghm_ObjMap_vrange have "set {a} ⊆∘ 𝔅⦇Obj⦈" by simp
    moreover have "𝔅⦇Obj⦈ ⊆∘ set {a}"
    proof(rule ccontr)
      assume "¬𝔅⦇Obj⦈ ⊆∘ set {a}"
      then obtain b where ba: "b ≠ a" and b: "b ∈∘ 𝔅⦇Obj⦈" by force
      define 𝔊 where "𝔊 = [set {⟨0, b⟩}, 0, dg_10 0, 𝔅]∘"
      have 𝔊_components: 
        "𝔊⦇ObjMap⦈ = set {⟨0, b⟩}"
        "𝔊⦇ArrMap⦈ = 0"
        "𝔊⦇HomDom⦈ = dg_10 0"
        "𝔊⦇HomCod⦈ = 𝔅"
        unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
      have 𝔊: "𝔊 : dg_10 0 ↦↦DGα 𝔅"
        by (rule is_dghmI, unfold 𝔊_components dg_10_components)
          (
            auto simp: 
              dg_cs_intros
              nat_omega_simps 
              digraph_dg_10
              𝔊_def 
              dg_10_is_arr_iff 
              b 
              vsubset_vsingleton_leftI
          )
      then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
      have "ℛ∘ (𝔊⦇ObjMap⦈) = set {b}" unfolding 𝔊_components by simp
      with vrange_𝔉 ba show False unfolding 𝔊_def by simp  
    qed
    ultimately have "𝔅⦇Obj⦈ = set {a}" by simp
    with that show ?thesis by simp
  qed
  obtain f where 𝔅_Arr: "𝔅⦇Arr⦈ = set {f}" and f: "f ∈∘ Vset α"
  proof-
    from prems(2)[OF digraph_dg_1, of 0 0] obtain 𝔉 
      where 𝔉: "𝔉 : dg_1 0 0 ↦↦DGα 𝔅" 
        and 𝔊𝔉: "𝔊 : dg_1 0 0 ↦↦DGα 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
      by fastforce
    interpret 𝔉: is_dghm α ‹dg_1 0 0› 𝔅 𝔉 by (rule 𝔉)
    have "𝒟∘ (𝔉⦇ObjMap⦈) = set {0}" 
      by (simp add: dg_cs_simps dg_1_components)
    then obtain a' where "ℛ∘ (𝔉⦇ObjMap⦈) = set {a'}"
      by 
        (
          auto 
            simp: dg_cs_simps 
            intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton
        )
    with 𝔅_Obj 𝔉.dghm_ObjMap_vrange have "ℛ∘ (𝔉⦇ObjMap⦈) = set {a}" by auto
    have "𝒟∘ (𝔉⦇ArrMap⦈) = set {0}" by (simp add: dg_cs_simps dg_1_components)
    then obtain f where vrange_𝔉[simp]: "ℛ∘ (𝔉⦇ArrMap⦈) = set {f}"
      by 
        (
          auto 
            simp: dg_cs_simps 
            intro: 𝔉.ArrMap.vsv_vdomain_vsingleton_vrange_vsingleton
        )
    with 𝔅.dg_Arr_vsubset_Vset 𝔉.dghm_ArrMap_vrange have [simp]: "f ∈∘ Vset α"
      by auto
    from 𝔉.dghm_ArrMap_vrange have "set {f} ⊆∘ 𝔅⦇Arr⦈" by simp
    moreover have "𝔅⦇Arr⦈ ⊆∘ set {f}"
    proof(rule ccontr)
      assume "¬𝔅⦇Arr⦈ ⊆∘ set {f}"
      then obtain g where gf: "g ≠ f" and g: "g ∈∘ 𝔅⦇Arr⦈" by force
      have g: "g : a ↦𝔅 a"
      proof(intro is_arrI)
        from g 𝔅_Obj show "𝔅⦇Dom⦈⦇g⦈ = a"
          by (metis 𝔅.dg_is_arrD(2) is_arr_def vsingleton_iff)
        from g 𝔅_Obj show "𝔅⦇Cod⦈⦇g⦈ = a"
          by (metis 𝔅.dg_is_arrD(3) is_arr_def vsingleton_iff)
      qed (auto simp: g)
      define 𝔊 where "𝔊 = [set {⟨0, a⟩}, set {⟨0, g⟩}, dg_1 0 0, 𝔅]∘"
      have 𝔊_components: 
        "𝔊⦇ObjMap⦈ = set {⟨0, a⟩}"
        "𝔊⦇ArrMap⦈ = set {⟨0, g⟩}"
        "𝔊⦇HomDom⦈ = dg_1 0 0"
        "𝔊⦇HomCod⦈ = 𝔅"
        unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
      have 𝔊: "𝔊 : dg_1 0 0  ↦↦DGα 𝔅"
        by (rule is_dghmI, unfold 𝔊_components dg_1_components)
          (
            auto simp: 
              dg_cs_intros nat_omega_simps 𝔊_def dg_1_is_arr_iff 𝔅_Obj g
          )
      then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
      have "ℛ∘ (𝔊⦇ArrMap⦈) = set {g}" unfolding 𝔊_components by simp
      with vrange_𝔉 gf show False unfolding 𝔊_def by simp  
    qed
    ultimately have "𝔅⦇Arr⦈ = set {f}" by simp
    with that show ?thesis by simp
  qed
  have "𝔅 = dg_1 a f"
  proof(rule dg_eqI[of α], unfold dg_1_components)
    show "𝔅⦇Obj⦈ = set {a}" by (simp add: 𝔅_Obj)
    moreover show "𝔅⦇Arr⦈ = set {f}" by (simp add: 𝔅_Arr)
    ultimately have "𝔅⦇Dom⦈⦇f⦈ = a" "𝔅⦇Cod⦈⦇f⦈ = a"
      by (metis 𝔅.dg_is_arrE is_arr_def vsingleton_iff)+
    have "𝒟∘ (𝔅⦇Dom⦈) = set {f}" by (simp add: dg_cs_simps 𝔅_Arr)
    moreover from 𝔅.Dom.vsv_vrange_vempty 𝔅.dg_Dom_vdomain 𝔅.dg_Dom_vrange  
    have "ℛ∘ (𝔅⦇Dom⦈) = set {a}" by (fastforce simp: 𝔅_Arr 𝔅_Obj)
    ultimately show "𝔅⦇Dom⦈ = set {⟨f, a⟩}"  
      using 𝔅.Dom.vsv_vdomain_vrange_vsingleton by simp
    have "𝒟∘ (𝔅⦇Cod⦈) = set {f}" by (simp add: dg_cs_simps 𝔅_Arr)
    moreover from 𝔅.Cod.vsv_vrange_vempty 𝔅.dg_Cod_vdomain 𝔅.dg_Cod_vrange  
    have "ℛ∘ (𝔅⦇Cod⦈) = set {a}" 
      by (fastforce simp: 𝔅_Arr 𝔅_Obj)
    ultimately show "𝔅⦇Cod⦈ = set {⟨f, a⟩}"  
      using assms 𝔅.Cod.vsv_vdomain_vrange_vsingleton by simp
  qed (auto simp: dg_cs_intros 𝔅_Obj digraph_dg_1 a f)
  with a f that show ?thesis by auto
qed

text‹\newpage›

end

Theory CZH_DG_SemiCAT

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹SemiCAT› as a digraph\label{sec:dg_SemiCAT}›
theory CZH_DG_SemiCAT
  imports 
    CZH_SMC_Semifunctor
    CZH_DG_Small_Digraph
begin



subsection‹Background›


text‹
‹SemiCAT› is usually defined as a category of semicategories and semifunctors
(e.g., see \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/semicategory}
}).
However, there is little that can prevent one from exposing ‹SemiCAT›
as a digraph and provide additional structure gradually in
subsequent theories. Thus, in this section, ‹α›-‹SemiCAT› is defined as a 
digraph of semicategories and semifunctors in ‹Vα›.
›

named_theorems dg_SemiCAT_simps
named_theorems dg_SemiCAT_intros



subsection‹Definition and elementary properties›

definition dg_SemiCAT :: "V ⇒ V"
  where "dg_SemiCAT α =
    [
      set {ℭ. semicategory α ℭ},
      all_smcfs α,
      (λ𝔉∈∘all_smcfs α. 𝔉⦇HomDom⦈),
      (λ𝔉∈∘all_smcfs α. 𝔉⦇HomCod⦈)
    ]∘"


text‹Components.›

lemma dg_SemiCAT_components:
  shows "dg_SemiCAT α⦇Obj⦈ = set {ℭ. semicategory α ℭ}"
    and "dg_SemiCAT α⦇Arr⦈ = all_smcfs α"
    and "dg_SemiCAT α⦇Dom⦈ = (λ𝔉∈∘all_smcfs α. 𝔉⦇HomDom⦈)"
    and "dg_SemiCAT α⦇Cod⦈ = (λ𝔉∈∘all_smcfs α. 𝔉⦇HomCod⦈)"
  unfolding dg_SemiCAT_def dg_field_simps by (simp_all add: nat_omega_simps)


subsection‹Object›

lemma dg_SemiCAT_ObjI:
  assumes "semicategory α 𝔄"
  shows "𝔄 ∈∘ dg_SemiCAT α⦇Obj⦈"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_ObjD:
  assumes "𝔄 ∈∘ dg_SemiCAT α⦇Obj⦈"
  shows "semicategory α 𝔄"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_ObjE:
  assumes "𝔄 ∈∘ dg_SemiCAT α⦇Obj⦈"
  obtains "semicategory α 𝔄"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_Obj_iff[dg_SemiCAT_simps]: 
  "𝔄 ∈∘ dg_SemiCAT α⦇Obj⦈ ⟷ semicategory α 𝔄"
  unfolding dg_SemiCAT_components by auto



subsection‹Domain and codomain›

lemma [dg_SemiCAT_simps]:
  assumes "𝔉 ∈∘ all_smcfs α"  
  shows dg_SemiCAT_Dom_app: "dg_SemiCAT α⦇Dom⦈⦇𝔉⦈ = 𝔉⦇HomDom⦈"
    and dg_SemiCAT_Cod_app: "dg_SemiCAT α⦇Cod⦈⦇𝔉⦈ = 𝔉⦇HomCod⦈"
  using assms unfolding dg_SemiCAT_components by auto



subsection‹‹SemiCAT› is a digraph›

lemma (in 𝒵) tiny_digraph_dg_SemiCAT: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_digraph β (dg_SemiCAT α)"
proof(intro tiny_digraphI)
  show "vfsequence (dg_SemiCAT α)" unfolding dg_SemiCAT_def by simp
  show "vcard (dg_SemiCAT α) = 4ℕ"
    unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
  show "ℛ∘ (dg_SemiCAT α⦇Dom⦈) ⊆∘ dg_SemiCAT α⦇Obj⦈" 
  proof(intro vsubsetI)
    fix 𝔄 assume "𝔄 ∈∘ ℛ∘ (dg_SemiCAT α⦇Dom⦈)"
    then obtain 𝔉 
      where "𝔉 ∈∘ all_smcfs α" and 𝔄_def: "𝔄 = 𝔉⦇HomDom⦈"
      unfolding dg_SemiCAT_components by auto
    then obtain 𝔅 𝔉 where "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
      unfolding dg_SemiCAT_components by auto
    then interpret is_semifunctor α 𝔄 𝔅 𝔉 .
    show "𝔄 ∈∘ dg_SemiCAT α⦇Obj⦈"
      by (simp add: dg_SemiCAT_components HomDom.semicategory_axioms)
  qed
  show "ℛ∘ (dg_SemiCAT α⦇Cod⦈) ⊆∘ dg_SemiCAT α⦇Obj⦈"
  proof(intro vsubsetI)
    fix 𝔅 assume "𝔅 ∈∘ ℛ∘ (dg_SemiCAT α⦇Cod⦈)"
    then obtain 𝔉 where "𝔉 ∈∘ 𝒟∘ (dg_SemiCAT α⦇Cod⦈)" and "𝔅 = 𝔉⦇HomCod⦈"
      unfolding dg_SemiCAT_components by auto
    then obtain 𝔄 𝔉 
      where 𝔉: "𝔉 : 𝔄 ↦↦SMCα 𝔅" and 𝔄_def: "𝔅 = 𝔉⦇HomCod⦈"
      unfolding dg_SemiCAT_components by auto
    have "𝔅 = 𝔉⦇HomCod⦈" unfolding 𝔄_def by simp
    interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule 𝔉)
    show "𝔅 ∈∘ dg_SemiCAT α⦇Obj⦈"
      by (simp add: HomCod.semicategory_axioms dg_SemiCAT_components)
  qed
  show "dg_SemiCAT α⦇Obj⦈ ∈∘ Vset β"
    unfolding dg_SemiCAT_components by (rule semicategories_in_Vset[OF assms])
  show "dg_SemiCAT α⦇Arr⦈ ∈∘ Vset β"
    unfolding dg_SemiCAT_components by (rule all_smcfs_in_Vset[OF assms])
qed (simp_all add: assms dg_SemiCAT_components)



subsection‹Arrow with a domain and a codomain›

lemma dg_SemiCAT_is_arrI:
  assumes "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
  shows "𝔉 : 𝔄 ↦dg_SemiCAT α 𝔅"
proof(intro is_arrI, unfold dg_SemiCAT_components(2))
  interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms)
  from assms show "𝔉 ∈∘ all_smcfs α" by auto
  with assms show "dg_SemiCAT α⦇Dom⦈⦇𝔉⦈ = 𝔄" "dg_SemiCAT α⦇Cod⦈⦇𝔉⦈ = 𝔅"
    by (simp_all add: smc_cs_simps dg_SemiCAT_components)
qed

lemma dg_SemiCAT_is_arrD:
  assumes "𝔉 : 𝔄 ↦dg_SemiCAT α 𝔅"
  shows "𝔉 : 𝔄 ↦↦SMCα 𝔅" 
  using assms by (elim is_arrE) (auto simp: dg_SemiCAT_components)

lemma dg_SemiCAT_is_arrE:
  assumes "𝔉 : 𝔄 ↦dg_SemiCAT α 𝔅"
  obtains "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  using assms by (simp add: dg_SemiCAT_is_arrD)

lemma dg_SemiCAT_is_arr_iff[dg_SemiCAT_simps]: 
  "𝔉 : 𝔄 ↦dg_SemiCAT α 𝔅 ⟷ 𝔉 : 𝔄 ↦↦SMCα 𝔅" 
  by (auto intro: dg_SemiCAT_is_arrI dest: dg_SemiCAT_is_arrD)

text‹\newpage›

end

Theory CZH_SMC_SemiCAT

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹SemiCAT› as a semicategory›
theory CZH_SMC_SemiCAT
  imports 
    CZH_DG_SemiCAT
    CZH_SMC_Simple
    CZH_SMC_Small_Semicategory
begin



subsection‹Background›


text‹
The subsection presents the theory of the semicategories of 
‹α›-semicategories.
It continues the development that was initiated in section 
\ref{sec:dg_SemiCAT}.
›

named_theorems smc_SemiCAT_simps
named_theorems smc_SemiCAT_intros



subsection‹Definition and elementary properties›

definition smc_SemiCAT :: "V ⇒ V"
  where "smc_SemiCAT α =
    [
      set {ℭ. semicategory α ℭ},
      all_smcfs α,
      (λ𝔉∈∘all_smcfs α. 𝔉⦇HomDom⦈),
      (λ𝔉∈∘all_smcfs α. 𝔉⦇HomCod⦈),
      (λ𝔊𝔉∈∘composable_arrs (dg_SemiCAT α). 𝔊𝔉⦇0⦈ ∘SMCF 𝔊𝔉⦇1ℕ⦈)
    ]∘"


text‹Components.›

lemma smc_SemiCAT_components:
  shows "smc_SemiCAT α⦇Obj⦈ = set {ℭ. semicategory α ℭ}"
    and "smc_SemiCAT α⦇Arr⦈ = all_smcfs α"
    and "smc_SemiCAT α⦇Dom⦈ = (λ𝔉∈∘all_smcfs α. 𝔉⦇HomDom⦈)"
    and "smc_SemiCAT α⦇Cod⦈ = (λ𝔉∈∘all_smcfs α. 𝔉⦇HomCod⦈)"
    and "smc_SemiCAT α⦇Comp⦈ =
      (λ𝔊𝔉∈∘composable_arrs (dg_SemiCAT α). 𝔊𝔉⦇0⦈ ∘SMCF 𝔊𝔉⦇1ℕ⦈)"
  unfolding smc_SemiCAT_def dg_field_simps 
  by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_SemiCAT[smc_SemiCAT_simps]: "smc_dg (smc_SemiCAT α) = dg_SemiCAT α"
proof(rule vsv_eqI)
  show "vsv (smc_dg (smc_SemiCAT α))" unfolding smc_dg_def by auto
  show "vsv (dg_SemiCAT α)" unfolding dg_SemiCAT_def by auto
  have dom_lhs: "𝒟∘ (smc_dg (smc_SemiCAT α)) = 4ℕ" 
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (dg_SemiCAT α) = 4ℕ"
    unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smc_dg (smc_SemiCAT α)) = 𝒟∘ (dg_SemiCAT α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smc_dg (smc_SemiCAT α)) ⟹ 
    smc_dg (smc_SemiCAT α)⦇a⦈ = dg_SemiCAT α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_SemiCAT_def dg_SemiCAT_def
      )
      (auto simp: nat_omega_simps)
qed

lemmas_with [folded smc_dg_SemiCAT, unfolded slicing_simps]: 
  smc_SemiCAT_ObjI = dg_SemiCAT_ObjI
  and smc_SemiCAT_ObjD = dg_SemiCAT_ObjD
  and smc_SemiCAT_ObjE = dg_SemiCAT_ObjE
  and smc_SemiCAT_Obj_iff[smc_SemiCAT_simps] = dg_SemiCAT_Obj_iff  
  and smc_SemiCAT_Dom_app[smc_SemiCAT_simps] = dg_SemiCAT_Dom_app
  and smc_SemiCAT_Cod_app[smc_SemiCAT_simps] = dg_SemiCAT_Cod_app
  and smc_SemiCAT_is_arrI = dg_SemiCAT_is_arrI
  and smc_SemiCAT_is_arrD = dg_SemiCAT_is_arrD
  and smc_SemiCAT_is_arrE = dg_SemiCAT_is_arrE
  and smc_SemiCAT_is_arr_iff[smc_SemiCAT_simps] = dg_SemiCAT_is_arr_iff



subsection‹Composable arrows›

lemma smc_SemiCAT_composable_arrs_dg_SemiCAT: 
  "composable_arrs (dg_SemiCAT α) = composable_arrs (smc_SemiCAT α)"
  unfolding composable_arrs_def smc_dg_SemiCAT[symmetric] slicing_simps by auto

lemma smc_SemiCAT_Comp: 
  "smc_SemiCAT α⦇Comp⦈ = 
    (λ𝔊𝔉∈∘composable_arrs (smc_SemiCAT α). 𝔊𝔉⦇0⦈ ∘DGHM 𝔊𝔉⦇1ℕ⦈)"
  unfolding smc_SemiCAT_components smc_SemiCAT_composable_arrs_dg_SemiCAT ..



subsection‹Composition›

lemma smc_SemiCAT_Comp_app[smc_SemiCAT_simps]:
  assumes "𝔊 : 𝔅 ↦smc_SemiCAT α ℭ" and "𝔉 : 𝔄 ↦smc_SemiCAT α 𝔅"
  shows "𝔊 ∘Asmc_SemiCAT α 𝔉 = 𝔊 ∘SMCF 𝔉"
proof-
  from assms have "[𝔊, 𝔉]∘ ∈∘ composable_arrs (smc_SemiCAT α)" 
    by (auto simp: composable_arrsI)
  then show "𝔊 ∘Asmc_SemiCAT α 𝔉 = 𝔊 ∘SMCF 𝔉"
    unfolding smc_SemiCAT_Comp by (simp add: nat_omega_simps)
qed 

lemma smc_SemiCAT_Comp_vdomain[smc_SemiCAT_simps]: 
  "𝒟∘ (smc_SemiCAT α⦇Comp⦈) = composable_arrs (smc_SemiCAT α)" 
  unfolding smc_SemiCAT_Comp by auto                      

lemma smc_SemiCAT_Comp_vrange: "ℛ∘ (smc_SemiCAT α⦇Comp⦈) ⊆∘ all_smcfs α"
proof(rule vsubsetI)
  fix ℌ assume "ℌ ∈∘ ℛ∘ (smc_SemiCAT α⦇Comp⦈)"
  then obtain 𝔊𝔉 
    where ℌ_def: "ℌ = smc_SemiCAT α⦇Comp⦈⦇𝔊𝔉⦈"
      and "𝔊𝔉 ∈∘ 𝒟∘ (smc_SemiCAT α⦇Comp⦈)"
    unfolding smc_SemiCAT_components by (auto intro: composable_arrsI)
  then obtain 𝔊 𝔉 𝔄 𝔅 ℭ 
    where "𝔊𝔉 = [𝔊, 𝔉]∘" 
      and 𝔊: "𝔊 : 𝔅 ↦smc_SemiCAT α ℭ" 
      and 𝔉: "𝔉 : 𝔄 ↦smc_SemiCAT α 𝔅"
    by (auto simp: smc_SemiCAT_Comp_vdomain) 
  with ℌ_def have ℌ_def': "ℌ = 𝔊 ∘Asmc_SemiCAT α 𝔉" by simp
  from 𝔊 𝔉 show "ℌ ∈∘ all_smcfs α" 
    unfolding ℌ_def' by (auto intro: smc_cs_intros simp: smc_SemiCAT_simps)
qed



subsection‹‹SemiCAT› is a semicategory›

lemma (in 𝒵) tiny_semicategory_smc_SemiCAT: 
  assumes "𝒵 β" and "α ∈∘ β"
  shows "tiny_semicategory β (smc_SemiCAT α)"
proof(intro tiny_semicategoryI, unfold smc_SemiCAT_is_arr_iff)
  show "vfsequence (smc_SemiCAT α)" unfolding smc_SemiCAT_def by auto
  show "vcard (smc_SemiCAT α) = 5ℕ"
    unfolding smc_SemiCAT_def by (simp add: nat_omega_simps)
  show "(𝔊𝔉 ∈∘ 𝒟∘ (smc_SemiCAT α⦇Comp⦈)) ⟷
    (∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]∘ ∧ 𝔊 : 𝔅 ↦↦SMCα ℭ ∧ 𝔉 : 𝔄 ↦↦SMCα 𝔅)"
    for 𝔊𝔉
    unfolding smc_SemiCAT_Comp_vdomain
  proof
    show "𝔊𝔉 ∈∘ composable_arrs (smc_SemiCAT α) ⟹ 
      ∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]∘ ∧ 𝔊   : 𝔅 ↦↦SMCα ℭ ∧ 𝔉 : 𝔄 ↦↦SMCα 𝔅"
      by (elim composable_arrsE) (auto simp: smc_SemiCAT_is_arr_iff)
  next
    assume "∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]∘ ∧ 𝔊 : 𝔅 ↦↦SMCα ℭ ∧ 𝔉 : 𝔄 ↦↦SMCα 𝔅"
    with smc_SemiCAT_is_arr_iff show "𝔊𝔉 ∈∘ composable_arrs (smc_SemiCAT α)"
      unfolding smc_SemiCAT_Comp_vdomain by (auto intro: smc_cs_intros)
  qed
  show "⟦ 𝔊 : 𝔅 ↦↦SMCα ℭ; 𝔉 : 𝔄 ↦↦SMCα 𝔅 ⟧ ⟹ 
    𝔊 ∘Asmc_SemiCAT α 𝔉 : 𝔄 ↦↦SMCα ℭ"
    for 𝔊 𝔅 ℭ 𝔉 𝔄
    by (auto simp: smc_SemiCAT_simps intro: smc_cs_intros)
  fix ℌ ℭ 𝔇 𝔊 𝔅 𝔉 𝔄
  assume "ℌ : ℭ ↦↦SMCα 𝔇" "𝔊 : 𝔅 ↦↦SMCα ℭ" "𝔉 : 𝔄 ↦↦SMCα 𝔅"
  moreover then have "𝔊 ∘SMCF 𝔉 : 𝔄 ↦↦SMCα ℭ" "ℌ ∘SMCF 𝔊 : 𝔅 ↦↦SMCα 𝔇" 
    by (auto intro: smc_cs_intros)
  ultimately show "ℌ ∘Asmc_SemiCAT α 𝔊 ∘Asmc_SemiCAT α 𝔉 = 
    ℌ ∘Asmc_SemiCAT α (𝔊 ∘Asmc_SemiCAT α 𝔉)"
    by 
      (
        simp add: 
          smc_SemiCAT_is_arr_iff smc_SemiCAT_Comp_app smcf_comp_assoc
      )
qed 
  (
    auto simp: 
      assms smc_dg_SemiCAT tiny_digraph_dg_SemiCAT smc_SemiCAT_components
  )



subsection‹Initial object›

lemma (in 𝒵) smc_SemiCAT_obj_initialI: "obj_initial (smc_SemiCAT α) smc_0"
  unfolding obj_initial_def
proof
  (
    intro obj_terminalI, 
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  show "semicategory α smc_0" by (intro semicategory_smc_0)
  fix 𝔄 assume prems: "semicategory α 𝔄"
  interpret semicategory α 𝔄 using prems .
  show "∃!𝔉. 𝔉 : smc_0 ↦↦SMCα 𝔄"
  proof
    show smcf_0: "smcf_0 𝔄 : smc_0 ↦↦SMCα 𝔄"
      by 
        (
          simp add: 
            smcf_0_is_semifunctor semicategory_axioms is_ft_semifunctor.axioms(1)
        )
    fix 𝔉 assume prems: "𝔉 : smc_0 ↦↦SMCα 𝔄" 
    then interpret 𝔉: is_semifunctor α smc_0 𝔄 𝔉 .
    show "𝔉 = smcf_0 𝔄"
    proof(rule smcf_eqI)
      show "𝔉 : smc_0 ↦↦SMCα 𝔄" by (auto simp: smc_cs_intros)
      from smcf_0 show "smcf_0 𝔄 : smc_0 ↦↦SMCα 𝔄"
        unfolding smc_SemiCAT_is_arr_iff by simp
      have "𝒟∘ (𝔉⦇ObjMap⦈) = 0" by (auto simp: smc_0_components smc_cs_simps)
      with 𝔉.ObjMap.vdomain_vrange_is_vempty show "𝔉⦇ObjMap⦈ = smcf_0 𝔄⦇ObjMap⦈"
        unfolding smcf_0_components by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
      have "𝒟∘ (𝔉⦇ArrMap⦈) = 0" by (auto simp: smc_0_components smc_cs_simps)
      with 𝔉.ArrMap.vdomain_vrange_is_vempty show "𝔉⦇ArrMap⦈ = smcf_0 𝔄⦇ArrMap⦈"
        unfolding smcf_0_components by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
    qed (simp_all add: smcf_0_components)
  qed
qed

lemma (in 𝒵) smc_SemiCAT_obj_initialD:
  assumes "obj_initial (smc_SemiCAT α) 𝔄"
  shows "𝔄 = smc_0" 
  using assms unfolding obj_initial_def
proof
  (
    elim obj_terminalE,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  assume prems: 
    "semicategory α 𝔄" 
    "semicategory α 𝔅 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    for 𝔅
  from prems(2)[OF semicategory_smc_0] obtain 𝔉 where "𝔉 : 𝔄 ↦↦SMCα smc_0" 
    by meson
  then interpret 𝔉: is_semifunctor α 𝔄 smc_0 𝔉 .
  have "ℛ∘ (𝔉⦇ObjMap⦈) ⊆∘ 0"
    unfolding smc_0_components(1)[symmetric]
    by (simp add: 𝔉.smcf_ObjMap_vrange)
  then have "𝔉⦇ObjMap⦈ = 0" by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
  with 𝔉.smcf_ObjMap_vdomain have Obj[simp]: "𝔄⦇Obj⦈ = 0" by auto
  have "ℛ∘ (𝔉⦇ArrMap⦈) ⊆∘ 0"
    unfolding smc_0_components(2)[symmetric]
    by (simp add: 𝔉.smcf_ArrMap_vrange)
  then have "𝔉⦇ArrMap⦈ = 0" by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
  with 𝔉.smcf_ArrMap_vdomain have Arr[simp]: "𝔄⦇Arr⦈ = 0" by auto
  from 𝔉.HomDom.Dom.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Dom⦈ = 0"  
    by (auto simp: smc_cs_simps intro: 𝔉.HomDom.Dom.vsv_vrange_vempty)
  from 𝔉.HomDom.Cod.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Cod⦈ = 0"
    by (auto simp: smc_cs_simps intro: 𝔉.HomDom.Cod.vsv_vrange_vempty)
  from Arr have "𝔄⦇Arr⦈ ^× 2ℕ = 0" by (simp add: vcpower_of_vempty)
  with 𝔉.HomDom.Comp.pnop_vdomain have "𝒟∘ (𝔄⦇Comp⦈) = 0" by simp
  with 𝔉.HomDom.Comp.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Comp⦈ = 0"
    by (auto intro: 𝔉.HomDom.Comp.vsv_vrange_vempty)
  show "𝔄 = smc_0"
    by (rule smc_eqI[of α])
      (simp_all add: prems(1) smc_0_components semicategory_smc_0)
qed

lemma (in 𝒵) smc_SemiCAT_obj_initialE:
  assumes "obj_initial (smc_SemiCAT α) 𝔄"
  obtains "𝔄 = smc_0" 
  using assms by (auto dest: smc_SemiCAT_obj_initialD)

lemma (in 𝒵) smc_SemiCAT_obj_initial_iff[smc_SemiCAT_simps]:
  "obj_initial (smc_SemiCAT α) 𝔄 ⟷ 𝔄 = smc_0"
  using smc_SemiCAT_obj_initialI smc_SemiCAT_obj_initialD by auto



subsection‹Terminal object›

lemma (in 𝒵) smc_SemiCAT_obj_terminalI[smc_SemiCAT_intros]: 
  assumes "a ∈∘ Vset α" and "f ∈∘ Vset α"
  shows "obj_terminal (smc_SemiCAT α) (smc_1 a f)"
proof
  (
    intro obj_terminalI,
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )
  fix 𝔄 assume "semicategory α 𝔄"
  then interpret semicategory α 𝔄 .
  show "∃!𝔉'. 𝔉' : 𝔄 ↦↦SMCα smc_1 a f"
  proof
    show smcf_1: "smcf_const 𝔄 (smc_1 a f) a f : 𝔄 ↦↦SMCα smc_1 a f"
      by 
        (
          auto 
            intro: smc_cs_intros smc_1_is_arrI smcf_const_is_semifunctor
            simp: assms semicategory_smc_1
        )
    fix 𝔉' assume "𝔉' : 𝔄 ↦↦SMCα smc_1 a f"
    then interpret 𝔉': is_semifunctor α 𝔄 ‹smc_1 a f› 𝔉' .
    show "𝔉' = smcf_const 𝔄 (smc_1 a f) a f"
    proof(rule smcf_eqI, unfold dghm_const_components)
      show "smcf_const 𝔄 (smc_1 a f) a f : 𝔄 ↦↦SMCα smc_1 a f" 
        by (rule smcf_1)
      show "𝔉'⦇ObjMap⦈ = vconst_on (𝔄⦇Obj⦈) a"
      proof(cases‹𝔄⦇Obj⦈ = 0›)
        case True
        with 𝔉'.ObjMap.vbrelation_vintersection_vdomain have "𝔉'⦇ObjMap⦈ = 0"
          by (auto simp: smc_cs_simps)
        with True show ?thesis by simp
      next
        case False
        then have "𝒟∘ (𝔉'⦇ObjMap⦈) ≠ 0" by (auto simp: smc_cs_simps)
        then have "ℛ∘ (𝔉'⦇ObjMap⦈) ≠ 0"
          by (simp add: 𝔉'.ObjMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from 𝔉'.smcf_ObjMap_vrange have "ℛ∘ (𝔉'⦇ObjMap⦈) ⊆∘ set {a}"
          by (simp add: smc_1_components)
        ultimately have "ℛ∘ (𝔉'⦇ObjMap⦈) = set {a}" by auto
        then show ?thesis 
          by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps) 
      qed
      show "𝔉'⦇ArrMap⦈ = vconst_on (𝔄⦇Arr⦈) f"
      proof(cases‹𝔄⦇Arr⦈ = 0›)
        case True
        with 𝔉'.ArrMap.vdomain_vrange_is_vempty have "𝔉'⦇ArrMap⦈ = 0"
          by (simp add: smc_cs_simps 𝔉'.smcf_ArrMap_vsv vsv.vsv_vrange_vempty)
        with True show ?thesis by simp
      next
        case False
        then have "𝒟∘ (𝔉'⦇ArrMap⦈) ≠ 0" by (auto simp: smc_cs_simps)
        then have "ℛ∘ (𝔉'⦇ArrMap⦈) ≠ 0" 
          by (simp add: 𝔉'.ArrMap.vsv_vdomain_vempty_vrange_vempty)
        moreover from 𝔉'.smcf_ArrMap_vrange have "ℛ∘ (𝔉'⦇ArrMap⦈) ⊆∘ set {f}"
          by (simp add: smc_1_components)
        ultimately have "ℛ∘ (𝔉'⦇ArrMap⦈) = set {f}" by auto
        then show ?thesis 
          by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps)
      qed
    qed (auto intro: smc_cs_intros)
  qed 
qed (simp add: assms semicategory_smc_1)

lemma (in 𝒵) smc_SemiCAT_obj_terminalE: 
  assumes "obj_terminal (smc_SemiCAT α) 𝔅"
  obtains a f where "a ∈∘ Vset α" and "f ∈∘ Vset α" and "𝔅 = smc_1 a f"
  using assms
proof
  (
    elim obj_terminalE, 
    unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
  )

  assume prems: 
    "semicategory α 𝔅" 
    "semicategory α 𝔄 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦SMCα 𝔅" 
    for 𝔄
  interpret 𝔅: semicategory α 𝔅 by (rule prems(1))

  obtain a where 𝔅_Obj: "𝔅⦇Obj⦈ = set {a}" and a: "a ∈∘ Vset α"
  proof-
    have semicategory_smc_10: "semicategory α (smc_10 0)"
      by (intro semicategory_smc_10) auto
    from prems(2)[OF semicategory_smc_10] obtain 𝔉 
      where 𝔉: "𝔉 : smc_10 0 ↦↦SMCα 𝔅" 
        and 𝔊𝔉: "𝔊 : smc_10 0 ↦↦SMCα 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
      by fastforce
    interpret 𝔉: is_semifunctor α ‹smc_10 0› 𝔅 𝔉 by (rule 𝔉)
    have "𝒟∘ (𝔉⦇ObjMap⦈) = set {0}" 
      by (auto simp add: smc_10_components smc_cs_simps)
    then obtain a where vrange_𝔉[simp]: "ℛ∘ (𝔉⦇ObjMap⦈) = set {a}"
      by (auto intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with 𝔅.smc_Obj_vsubset_Vset 𝔉.smcf_ObjMap_vrange have [simp]: "a ∈∘ Vset α"
      by auto
    from 𝔉.smcf_ObjMap_vrange have "set {a} ⊆∘ 𝔅⦇Obj⦈" by simp
    moreover have "𝔅⦇Obj⦈ ⊆∘ set {a}"
    proof(rule ccontr)
      assume "¬ 𝔅⦇Obj⦈ ⊆∘ set {a}"
      then obtain b where ba: "b ≠ a" and b: "b ∈∘ 𝔅⦇Obj⦈" by force
      define 𝔊 where "𝔊 = [set {⟨0, b⟩}, 0, smc_10 0, 𝔅]∘"
      have 𝔊_components: 
        "𝔊⦇ObjMap⦈ = set {⟨0, b⟩}"
        "𝔊⦇ArrMap⦈ = 0"
        "𝔊⦇HomDom⦈ = smc_10 0"
        "𝔊⦇HomCod⦈ = 𝔅"
        unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
      have 𝔊: "𝔊 : smc_10 0 ↦↦SMCα 𝔅"
      proof(rule is_semifunctorI, unfold 𝔊_components smc_10_components)
        show "vfsequence 𝔊" unfolding 𝔊_def by auto
        show "vcard 𝔊 = 4ℕ"
          unfolding 𝔊_def by (auto simp: nat_omega_simps)
        show "smcf_dghm 𝔊 : smc_dg (smc_10 0) ↦↦DGα smc_dg 𝔅"
        proof(intro is_dghmI, unfold 𝔊_components dg_10_components smc_dg_smc_10)
          show "vfsequence (smcf_dghm 𝔊)" unfolding smcf_dghm_def by simp
          show "vcard (smcf_dghm 𝔊) = 4ℕ"
            unfolding smcf_dghm_def by (simp add: nat_omega_simps)
        qed 
          (
            auto simp: 
              slicing_simps slicing_intros slicing_commute smc_dg_smc_10 
              b 𝔊_components dg_10_is_arr_iff digraph_dg_10 
          )
      qed (auto simp: smc_cs_intros smc_10_is_arr_iff b vsubset_vsingleton_leftI)
      then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
      have "ℛ∘ (𝔊⦇ObjMap⦈) = set {b}" unfolding 𝔊_components by simp
      with vrange_𝔉 ba show False unfolding 𝔊_def by simp  
    qed
    ultimately have "𝔅⦇Obj⦈ = set {a}" by simp
    with that show ?thesis by simp
  qed

  obtain f 
    where 𝔅_Arr: "𝔅⦇Arr⦈ = set {f}" 
      and f: "f ∈∘ Vset α"
      and ff_f: "f ∘A𝔅 f = f"
  proof-
    from prems(2)[OF semicategory_smc_1, of 0 0] obtain 𝔉 
      where "𝔉 : smc_1 0 0 ↦↦SMCα 𝔅" 
        and "𝔊 : smc_1 0 0 ↦↦SMCα 𝔅 ⟹ 𝔊 = 𝔉" 
      for 𝔊
      by fastforce
    then interpret 𝔉: is_semifunctor α ‹smc_1 0 0› 𝔅 𝔉 by force
    have "𝒟∘ (𝔉⦇ObjMap⦈) = set {0}" 
      by (simp add: smc_cs_simps smc_1_components)
    then obtain a' where "ℛ∘ (𝔉⦇ObjMap⦈) = set {a'}"
      by (auto intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with 𝔉.smcf_ObjMap_vrange have "ℛ∘ (𝔉⦇ObjMap⦈) = set {a}" 
      by (auto simp: 𝔅_Obj)
    have vdomain_𝔉: "𝒟∘ (𝔉⦇ArrMap⦈) = set {0}"
      by (simp add: smc_cs_simps smc_1_components)
    then obtain f where vrange_𝔉[simp]: "ℛ∘ (𝔉⦇ArrMap⦈) = set {f}"
      by (auto intro: 𝔉.ArrMap.vsv_vdomain_vsingleton_vrange_vsingleton)
    with 𝔅.smc_Arr_vsubset_Vset 𝔉.smcf_ArrMap_vrange have [simp]: "f ∈∘ Vset α"
      by auto
    from 𝔉.smcf_ArrMap_vrange have f_ss_𝔅: "set {f} ⊆∘ 𝔅⦇Arr⦈" by simp
    then have "f ∈∘ 𝔅⦇Arr⦈" by auto
    then have f: "f : a ↦𝔅 a"
      by (metis 𝔅_Obj 𝔅.smc_is_arrD(2,3) is_arrI vsingleton_iff)
    from vdomain_𝔉 𝔉.ArrMap.vsv_value have [simp]: "𝔉⦇ArrMap⦈⦇0⦈ = f" by auto
    from 𝔉.smcf_is_arr_HomCod(2) have [simp]: "𝔉⦇ObjMap⦈⦇0⦈ = a"
      by (auto simp: smc_1_is_arr_iff 𝔅_Obj)
    have "𝔉⦇ArrMap⦈⦇0⦈ ∘A𝔅 𝔉⦇ArrMap⦈⦇0⦈ = 𝔉⦇ArrMap⦈⦇0⦈"
      by (metis smc_1_Comp_app 𝔉.smcf_ArrMap_Comp smc_1_is_arr_iff)
    then have ff_f[simp]: "f ∘A𝔅 f = f" by simp
    have id_𝔅: "smcf_id 𝔅 : 𝔅 ↦↦SMCα 𝔅"
      by (simp add: 𝔅.smc_smcf_id_is_semifunctor)
    interpret id_𝔅: is_semifunctor α 𝔅 𝔅 ‹smcf_id 𝔅› by (rule id_𝔅)
    from prems(2)[OF 𝔅.semicategory_axioms] have 
      "𝔊 : 𝔅 ↦↦SMCα 𝔅 ⟹ 𝔊 = smcf_id 𝔅" for 𝔊
      by (clarsimp simp: id_𝔅.is_semifunctor_axioms)
    moreover from f have "smcf_const 𝔅 𝔅 a f : 𝔅 ↦↦SMCα 𝔅"
      by (intro smcf_const_is_semifunctor) (auto intro: smc_cs_intros)
    ultimately have const_eq_id: "smcf_const 𝔅 𝔅 a f = smcf_id 𝔅" by simp
    have "𝔅⦇Arr⦈ ⊆∘ set {f}"
    proof(rule ccontr)
      assume "¬𝔅⦇Arr⦈ ⊆∘ set {f}"
      then obtain g where gf: "g ≠ f" and g: "g ∈∘ 𝔅⦇Arr⦈" by force
      have g: "g : a ↦𝔅 a"
      proof(intro is_arrI)
        from g 𝔅_Obj show "𝔅⦇Dom⦈⦇g⦈ = a"
          by (metis 𝔅.smc_is_arrD(2) is_arr_def vsingleton_iff)
        from g 𝔅_Obj show "𝔅⦇Cod⦈⦇g⦈ = a"
          by (metis 𝔅.smc_is_arrD(3) is_arr_def vsingleton_iff)
      qed (auto simp: g)
      then have "smcf_const 𝔅 𝔅 a f⦇ArrMap⦈⦇g⦈ = f" 
        by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)       
      moreover from g have "smcf_id 𝔅⦇ArrMap⦈⦇g⦈ = g"
        by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)       
      ultimately show False using const_eq_id by (simp add: gf)
    qed
    with f_ss_𝔅 have "𝔅⦇Arr⦈ = set {f}" by simp
    with that show ?thesis by simp
  qed

  have "𝔅 = smc_1 a f"
  proof(rule smc_eqI [of α], unfold smc_1_components)
    show "𝔅⦇Obj⦈ = set {a}" by (simp add: 𝔅_Obj)
    moreover show "𝔅⦇Arr⦈ = set {f}" by (simp add: 𝔅_Arr)
    ultimately have dom: "𝔅⦇Dom⦈⦇f⦈ = a" and cod: "𝔅⦇Cod⦈⦇f⦈ = a"
      by (metis 𝔅.smc_is_arrE is_arr_def vsingleton_iff)+
    have "𝒟∘ (𝔅⦇Dom⦈) = set {f}" by (simp add: 𝔅_Arr smc_cs_simps)
    moreover from 𝔅.Dom.vsv_vrange_vempty 𝔅.smc_Dom_vdomain 𝔅.smc_Dom_vrange  
    have "ℛ∘ (𝔅⦇Dom⦈) = set {a}" 
      by (fastforce simp: 𝔅_Arr 𝔅_Obj)
    ultimately show "𝔅⦇Dom⦈ = set {⟨f, a⟩}"  
      using assms 𝔅.Dom.vsv_vdomain_vrange_vsingleton by simp
    have "𝒟∘ (𝔅⦇Cod⦈) = set {f}" by (simp add: 𝔅_Arr smc_cs_simps)
    moreover from 𝔅.Cod.vsv_vrange_vempty 𝔅.smc_Cod_vdomain 𝔅.smc_Cod_vrange  
    have "ℛ∘ (𝔅⦇Cod⦈) = set {a}" 
      by (fastforce simp: 𝔅_Arr 𝔅_Obj)
    ultimately show "𝔅⦇Cod⦈ = set {⟨f, a⟩}"  
      using assms 𝔅.Cod.vsv_vdomain_vrange_vsingleton by simp
    show "𝔅⦇Comp⦈ = set {⟨[f, f]∘, f⟩}"
    proof(rule vsv_eqI)
      show [simp]: "𝒟∘ (𝔅⦇Comp⦈) = 𝒟∘ (set {⟨[f, f]∘, f⟩})"
        unfolding vdomain_vsingleton
      proof(rule vsubset_antisym)
        from 𝔅.Comp.pnop_vdomain show "𝒟∘ (𝔅⦇Comp⦈) ⊆∘ set {[f, f]∘}"
          by (auto simp: 𝔅_Arr intro: smc_cs_intros) (*slow*)
        from 𝔅_Arr dom cod is_arrI show "set {[f, f]∘} ⊆∘ 𝒟∘ (𝔅⦇Comp⦈)"
          by (metis 𝔅.smc_Comp_vdomainI vsingletonI vsubset_vsingleton_leftI)
      qed
      from ff_f show "a ∈∘ 𝒟∘ (𝔅⦇Comp⦈) ⟹ 𝔅⦇Comp⦈⦇a⦈ = set {⟨[f, f]∘, f⟩}⦇a⦈" 
        for a
        by simp
    qed auto
  qed (auto intro: smc_cs_intros a f semicategory_smc_1)
  with a f that show ?thesis by auto

qed

text‹\newpage›

end

Theory CZH_SMC_Rel

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Rel› as a semicategory›
theory CZH_SMC_Rel
  imports 
    CZH_DG_Rel
    CZH_SMC_Semifunctor
    CZH_SMC_Small_Semicategory
begin



subsection‹Background›


text‹
The methodology chosen for the exposition 
of ‹Rel› as a semicategory is analogous to the 
one used in the previous chapter for the exposition of ‹Rel› as a digraph. 
The general references for this section are Chapter I-7 
in \cite{mac_lane_categories_2010} and nLab 
\cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/Rel}
}.
›

named_theorems smc_Rel_cs_simps
named_theorems smc_Rel_cs_intros

lemmas (in arr_Rel) [smc_Rel_cs_simps] = 
  dg_Rel_shared_cs_simps

lemmas [smc_Rel_cs_simps] = 
  dg_Rel_shared_cs_simps
  arr_Rel.arr_Rel_length
  arr_Rel_comp_Rel_id_Rel_left
  arr_Rel_comp_Rel_id_Rel_right
  arr_Rel.arr_Rel_converse_Rel_converse_Rel
  arr_Rel_converse_Rel_eq_iff
  arr_Rel_converse_Rel_comp_Rel
  arr_Rel_comp_Rel_converse_Rel_left_if_v11
  arr_Rel_comp_Rel_converse_Rel_right_if_v11

lemmas [smc_Rel_cs_intros] =
  dg_Rel_shared_cs_intros
  arr_Rel_comp_Rel
  arr_Rel.arr_Rel_converse_Rel



subsection‹‹Rel› as a semicategory›


subsubsection‹Definition and elementary properties›

definition smc_Rel :: "V ⇒ V"
  where "smc_Rel α =
    [
      Vset α,
      set {T. arr_Rel α T},
      (λT∈∘set {T. arr_Rel α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Rel α T}. T⦇ArrCod⦈),
      (λST∈∘composable_arrs (dg_Rel α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)
    ]∘"


text‹Components.›

lemma smc_Rel_components:
  shows "smc_Rel α⦇Obj⦈ = Vset α"
    and "smc_Rel α⦇Arr⦈ = set {T. arr_Rel α T}"
    and "smc_Rel α⦇Dom⦈ = (λT∈∘set {T. arr_Rel α T}. T⦇ArrDom⦈)"
    and "smc_Rel α⦇Cod⦈ = (λT∈∘set {T. arr_Rel α T}. T⦇ArrCod⦈)"
    and "smc_Rel α⦇Comp⦈ = (λST∈∘composable_arrs (dg_Rel α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Rel_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_smc_Rel: "smc_dg (smc_Rel α) = dg_Rel α"
proof(rule vsv_eqI)
  show "vsv (smc_dg (smc_Rel α))" unfolding smc_dg_def by auto
  show "vsv (dg_Rel α)" unfolding dg_Rel_def by auto
  have dom_lhs: "𝒟∘ (smc_dg (smc_Rel α)) = 4ℕ" 
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (dg_Rel α) = 4ℕ"
    unfolding dg_Rel_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smc_dg (smc_Rel α)) = 𝒟∘ (dg_Rel α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smc_dg (smc_Rel α)) ⟹ smc_dg (smc_Rel α)⦇a⦈ = dg_Rel α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs,
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_Rel_def dg_Rel_def
      )
      (auto simp: nat_omega_simps)
qed

lemmas_with [folded smc_dg_smc_Rel, unfolded slicing_simps]: 
  smc_Rel_Obj_iff = dg_Rel_Obj_iff
  and smc_Rel_Arr_iff[smc_Rel_cs_simps] = dg_Rel_Arr_iff
  and smc_Rel_Dom_vsv[smc_Rel_cs_intros] = dg_Rel_Dom_vsv
  and smc_Rel_Dom_vdomain[smc_Rel_cs_simps] = dg_Rel_Dom_vdomain
  and smc_Rel_Dom_app[smc_Rel_cs_simps] = dg_Rel_Dom_app
  and smc_Rel_Dom_vrange = dg_Rel_Dom_vrange
  and smc_Rel_Cod_vsv[smc_Rel_cs_intros] = dg_Rel_Cod_vsv
  and smc_Rel_Cod_vdomain[smc_Rel_cs_simps] = dg_Rel_Cod_vdomain
  and smc_Rel_Cod_app[smc_Rel_cs_simps] = dg_Rel_Cod_app
  and smc_Rel_Cod_vrange = dg_Rel_Cod_vrange
  and smc_Rel_is_arrI[smc_Rel_cs_intros] = dg_Rel_is_arrI
  and smc_Rel_is_arrD = dg_Rel_is_arrD
  and smc_Rel_is_arrE = dg_Rel_is_arrE

lemmas [smc_cs_simps] = smc_Rel_is_arrD(2,3)

lemmas_with (in 𝒵) [folded smc_dg_smc_Rel, unfolded slicing_simps]: 
  smc_Rel_Hom_vifunion_in_Vset = dg_Rel_Hom_vifunion_in_Vset
  and smc_Rel_incl_Rel_is_arr = dg_Rel_incl_Rel_is_arr
  and smc_Rel_incl_Rel_is_arr'[smc_Rel_cs_intros] = dg_Rel_incl_Rel_is_arr'

lemmas [smc_Rel_cs_intros] = 𝒵.smc_Rel_incl_Rel_is_arr'


subsubsection‹Composable arrows›

lemma smc_Rel_composable_arrs_dg_Rel: 
  "composable_arrs (dg_Rel α) = composable_arrs (smc_Rel α)"
  unfolding composable_arrs_def smc_dg_smc_Rel[symmetric] slicing_simps by simp

lemma smc_Rel_Comp: 
  "smc_Rel α⦇Comp⦈ = (λST∈∘composable_arrs (smc_Rel α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Rel_components smc_Rel_composable_arrs_dg_Rel ..


subsubsection‹Composition›

lemma smc_Rel_Comp_app[smc_Rel_cs_simps]:
  assumes "S : b ↦smc_Rel α c" and "T : a ↦smc_Rel α b"
  shows "S ∘Asmc_Rel α T = S ∘Rel T"
proof-
  from assms have "[S, T]∘ ∈∘ composable_arrs (smc_Rel α)" 
    by (auto intro: smc_cs_intros)
  then show "S ∘Asmc_Rel α T = S ∘Rel T"
    unfolding smc_Rel_Comp by (simp add: nat_omega_simps)
qed 

lemma smc_Rel_Comp_vdomain: "𝒟∘ (smc_Rel α⦇Comp⦈) = composable_arrs (smc_Rel α)" 
  unfolding smc_Rel_Comp by simp

lemma (in 𝒵) smc_CAT_Comp_vrange:
  "ℛ∘ (smc_Rel α⦇Comp⦈) ⊆∘ set {T. arr_Rel α T}"
proof(rule vsubsetI)
  interpret digraph α ‹smc_dg (smc_Rel α)›
    unfolding smc_dg_smc_Rel by (simp add: digraph_dg_Rel)
  fix R assume "R ∈∘ ℛ∘ (smc_Rel α⦇Comp⦈)"
  then obtain ST 
    where R_def: "R = smc_Rel α⦇Comp⦈⦇ST⦈"
      and "ST ∈∘ 𝒟∘ (smc_Rel α⦇Comp⦈)"
    unfolding smc_Rel_components by (auto intro: smc_cs_intros)
  then obtain S T a b c 
    where "ST = [S, T]∘" 
      and S: "S : b ↦smc_Rel α c" 
      and T: "T : a ↦smc_Rel α b"
    by (auto simp: smc_Rel_Comp_vdomain)
  with R_def have R_def': "R = S ∘Asmc_Rel α T" by simp
  note S_D = dg_is_arrD(1)[unfolded slicing_simps, OF S]
  note T_D = dg_is_arrD(1)[unfolded slicing_simps, OF T]
  from S_D T_D have "arr_Rel α S" "arr_Rel α T" 
    by (simp_all add: smc_Rel_components)
  from this show "R ∈∘ set {T. arr_Rel α T}" 
    unfolding R_def' smc_Rel_Comp_app[OF S T] by (auto simp: arr_Rel_comp_Rel)
qed


subsubsection‹‹Rel› is a semicategory›

lemma (in 𝒵) semicategory_smc_Rel: "semicategory α (smc_Rel α)"
proof(rule semicategoryI, unfold smc_dg_smc_Rel)
  show "vfsequence (smc_Rel α)" unfolding smc_Rel_def by simp
  show "vcard (smc_Rel α) = 5ℕ" 
    unfolding smc_Rel_def by (simp add: nat_omega_simps)
  show "gf ∈∘ 𝒟∘ (smc_Rel α⦇Comp⦈) ⟷ 
    (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦smc_Rel α c ∧ f : a ↦smc_Rel α b)"
    for gf
    unfolding smc_Rel_Comp_vdomain by (auto intro: composable_arrsI)
  show "g ∘Asmc_Rel α f : a ↦smc_Rel α c"
    if "g : b ↦smc_Rel α c" and "f : a ↦smc_Rel α b" for g b c f a
  proof-
    from that have "arr_Rel α g" and "arr_Rel α f" 
      by (auto simp: smc_Rel_is_arrD(1))
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Rel_cs_simps cs_intro: smc_Rel_cs_intros
        )
  qed
  show "h ∘Asmc_Rel α g ∘Asmc_Rel α f = h ∘Asmc_Rel α (g ∘Asmc_Rel α f)"
    if "h : c ↦smc_Rel α d" 
      and "g : b ↦smc_Rel α c"
      and "f : a ↦smc_Rel α b"
    for h c d g b f a
  proof-
    from that have "arr_Rel α h" and "arr_Rel α g" and "arr_Rel α f" 
      by (auto simp: smc_Rel_is_arrD(1))
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Rel_cs_simps 
            cs_intro: smc_Rel_cs_intros
        )
  qed
qed (auto simp: digraph_dg_Rel smc_Rel_components)



subsection‹Canonical dagger for ‹Rel››


subsubsection‹Definition and elementary properties›

definition smcf_dag_Rel :: "V ⇒ V" (‹†SMC.Rel›)
  where "†SMC.Rel α =
    [
      vid_on (smc_Rel α⦇Obj⦈),
      VLambda (smc_Rel α⦇Arr⦈) converse_Rel,
      op_smc (smc_Rel α), 
      smc_Rel α
    ]∘"


text‹Components.›

lemma smcf_dag_Rel_components:
  shows "†SMC.Rel α⦇ObjMap⦈ = vid_on (smc_Rel α⦇Obj⦈)"
    and "†SMC.Rel α⦇ArrMap⦈ = VLambda (smc_Rel α⦇Arr⦈) converse_Rel"
    and "†SMC.Rel α⦇HomDom⦈ = op_smc (smc_Rel α)"
    and "†SMC.Rel α⦇HomCod⦈ = smc_Rel α"
  unfolding smcf_dag_Rel_def dghm_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smcf_dghm_smcf_dag_Rel: "smcf_dghm (†SMC.Rel α) = †DG.Rel α"
proof(rule vsv_eqI)
  show "vsv (smcf_dghm (†SMC.Rel α))" unfolding smcf_dghm_def by auto
  show "vsv (†DG.Rel α)" unfolding dghm_dag_Rel_def by auto
  have dom_lhs: "𝒟∘ (smcf_dghm (†SMC.Rel α)) = 4ℕ" 
    unfolding smcf_dghm_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (†DG.Rel α) = 4ℕ"
    unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smcf_dghm (†SMC.Rel α)) = 𝒟∘ (†DG.Rel α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smcf_dghm (†SMC.Rel α)) ⟹
    smcf_dghm (†SMC.Rel α)⦇a⦈ = †DG.Rel α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral, 
        unfold dghm_field_simps[symmetric],
        unfold 
          smc_dg_smc_Rel
          slicing_commute[symmetric]
          smcf_dghm_components 
          dghm_dag_Rel_components
          smcf_dag_Rel_components
          dg_Rel_components
          smc_Rel_components
      )
      simp_all
qed

lemmas_with [
    folded smc_dg_smc_Rel smcf_dghm_smcf_dag_Rel, 
    unfolded slicing_simps
    ]: 
  smcf_dag_Rel_ObjMap_vsv[smc_Rel_cs_intros] = dghm_dag_Rel_ObjMap_vsv
  and smcf_dag_Rel_ObjMap_vdomain[smc_Rel_cs_simps] = 
    dghm_dag_Rel_ObjMap_vdomain
  and smcf_dag_Rel_ObjMap_app[smc_Rel_cs_simps] = dghm_dag_Rel_ObjMap_app
  and smcf_dag_Rel_ObjMap_vrange[smc_Rel_cs_simps] = dghm_dag_Rel_ObjMap_vrange
  and smcf_dag_Rel_ArrMap_vsv[smc_Rel_cs_intros] = dghm_dag_Rel_ArrMap_vsv
  and smcf_dag_Rel_ArrMap_vdomain[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_vdomain
  and smcf_dag_Rel_ArrMap_app[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_app
  and smcf_dag_Rel_ArrMap_vrange[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_vrange

lemmas_with (in 𝒵) [
    folded smc_dg_smc_Rel smcf_dghm_smcf_dag_Rel, unfolded slicing_simps
    ]: 
  smcf_dag_Rel_app_is_arr = dghm_dag_Rel_ArrMap_app_is_arr


subsubsection‹Canonical dagger is a contravariant isomorphism of ‹Rel››

lemma (in 𝒵) smcf_dag_Rel_is_iso_semifunctor: 
  "†SMC.Rel α : op_smc (smc_Rel α) ↦↦SMC.isoα smc_Rel α"
proof(rule is_iso_semifunctorI)
  interpret dag: is_iso_dghm α ‹op_dg (dg_Rel α)› ‹dg_Rel α› ‹†DG.Rel α›
    by (rule dghm_dag_Rel_is_iso_dghm)
  interpret Rel: semicategory α ‹smc_Rel α› 
    by (rule semicategory_smc_Rel)
  show "†SMC.Rel α : op_smc (smc_Rel α) ↦↦SMCα smc_Rel α"
  proof
    (
      rule is_semifunctorI,
      unfold 
        smc_dg_smc_Rel 
        smcf_dghm_smcf_dag_Rel 
        smc_op_simps 
        slicing_commute[symmetric] 
        smcf_dag_Rel_components(3,4)
    )
    show "vfsequence (†SMC.Rel α)"
      unfolding smcf_dag_Rel_def by (simp add: nat_omega_simps)
    show "vcard (†SMC.Rel α) = 4ℕ"
      unfolding smcf_dag_Rel_def by (simp add: nat_omega_simps)
    show "†SMC.Rel α⦇ArrMap⦈⦇f ∘Asmc_Rel α g⦈ =
      †SMC.Rel α⦇ArrMap⦈⦇g⦈ ∘Asmc_Rel α †SMC.Rel α⦇ArrMap⦈⦇f⦈"
      if "g : c ↦smc_Rel α b" and "f : b ↦smc_Rel α a"
      for g b c f a
    proof-
      from that have "arr_Rel α g" and "arr_Rel α f" 
        by (auto simp: smc_Rel_is_arrD(1))
      with that show ?thesis
        by 
          (
            cs_concl 
              cs_simp: smc_cs_simps smc_Rel_cs_simps 
              cs_intro: smc_Rel_cs_intros
          )
    qed
  qed (auto simp: dg_cs_intros smc_op_intros semicategory_smc_Rel) 

  show "smcf_dghm (†SMC.Rel α) :
    smc_dg (op_smc (smc_Rel α)) ↦↦DG.isoα smc_dg (smc_Rel α)"
    by 
      (
        simp add: 
          smc_dg_smc_Rel 
          smcf_dghm_smcf_dag_Rel 
          smc_op_simps 
          slicing_simps 
          slicing_commute[symmetric] 
          dghm_dag_Rel_is_iso_dghm
      )
                                        
qed


subsubsection‹Further properties of the canonical dagger›

lemma (in 𝒵) smcf_cn_comp_smcf_dag_Rel_smcf_dag_Rel: 
  "†SMC.Rel α SMCF∘ †SMC.Rel α = smcf_id (smc_Rel α)"
proof(rule smcf_dghm_eqI)
  interpret semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)
  from smcf_dag_Rel_is_iso_semifunctor have dag:
    "†SMC.Rel α : op_smc (smc_Rel α) ↦↦SMCα smc_Rel α"
    by (simp add: is_iso_semifunctor.axioms(1))
  from smcf_cn_comp_is_semifunctor[OF semicategory_axioms dag dag] show 
    "†SMC.Rel α SMCF∘ †SMC.Rel α : smc_Rel α ↦↦SMCα smc_Rel α" .
  show "smcf_id (smc_Rel α) : smc_Rel α ↦↦SMCα smc_Rel α"
    by (auto simp: smc_smcf_id_is_semifunctor)
  show "smcf_dghm (†SMC.Rel α SMCF∘ †SMC.Rel α) = smcf_dghm (smcf_id (smc_Rel α))"
    unfolding 
      slicing_simps slicing_commute[symmetric] 
      smc_dg_smc_Rel 
      smcf_dghm_smcf_dag_Rel
    by (simp add: dghm_cn_comp_dghm_dag_Rel_dghm_dag_Rel)
qed simp_all

lemma (in 𝒵) smcf_dag_Rel_ArrMap_smc_Rel_Comp:
  assumes "S : b ↦smc_Rel α c" and "T : a ↦smc_Rel α b"
  shows "†SMC.Rel α⦇ArrMap⦈⦇S ∘Asmc_Rel α T⦈ =
    †SMC.Rel α⦇ArrMap⦈⦇T⦈ ∘Asmc_Rel α †SMC.Rel α⦇ArrMap⦈⦇S⦈"
proof-
  from assms have "arr_Rel α S" and "arr_Rel α T" 
    by (auto simp: smc_Rel_is_arrD(1))
  with assms show ?thesis
    by 
      (
        cs_concl 
          cs_simp: smc_cs_simps smc_Rel_cs_simps cs_intro: smc_Rel_cs_intros
      )
qed



subsection‹Monic arrow and epic arrow›


text‹
The conditions for an arrow of ‹Rel› to be either monic or epic are 
outlined in nLab \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/Rel}
}.
›

context 𝒵
begin

context
begin

private lemma smc_Rel_is_monic_arr_vsubset: 
  assumes "T : A ↦smc_Rel α B" 
    and "R : A' ↦smc_Rel α A" 
    and "S : A' ↦smc_Rel α A" 
    and "T ∘Asmc_Rel α R = T ∘Asmc_Rel α S"
    and "⋀y z X. 
      ⟦ y ⊆∘ A; z ⊆∘ A; T⦇ArrVal⦈ `∘ y = X; T⦇ArrVal⦈ `∘ z = X ⟧ ⟹ y = z"
  shows "R⦇ArrVal⦈ ⊆∘ S⦇ArrVal⦈"
proof-
  interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
  interpret R: arr_Rel α R 
    rewrites "R⦇ArrDom⦈ = A'" and "R⦇ArrCod⦈ = A"
    using assms(2)
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
  interpret S: arr_Rel α S
    rewrites "S⦇ArrDom⦈ = A'" and "S⦇ArrCod⦈ = A"
    using assms(3)
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
  from assms(4) have "(T ∘Asmc_Rel α R)⦇ArrVal⦈ = (T ∘Asmc_Rel α S)⦇ArrVal⦈"
    by simp
  then have eq: "T⦇ArrVal⦈ ∘∘ R⦇ArrVal⦈ = T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈"
    unfolding 
      smc_Rel_Comp_app[OF assms(1,2)]
      smc_Rel_Comp_app[OF assms(1,3)]
      comp_Rel_components
    by simp
  show "R⦇ArrVal⦈ ⊆∘ S⦇ArrVal⦈"
  proof(rule vsubsetI)    
    fix ab assume ab[intro]: "ab ∈∘ R⦇ArrVal⦈"
    with R.ArrVal.vbrelation obtain a b where ab_def: "ab = ⟨a, b⟩" by auto 
    with ab R.arr_Rel_ArrVal_vrange have "a ∈∘ 𝒟∘ (R⦇ArrVal⦈)" and "b ∈∘ A" 
      by auto
    define B' and C' where "B' = R⦇ArrVal⦈ `∘ set {a}" and "C' = T⦇ArrVal⦈ `∘ B'"
    have ne_C': "C' ≠ 0"
    proof(rule ccontr, unfold not_not)
      assume prems: "C' = 0"
      from ab have "b ∈∘ B'" unfolding ab_def B'_def by simp
      with C'_def[unfolded prems] have b0: "T⦇ArrVal⦈ `∘ set {b} = 0" by auto
      from assms(5)[OF _ _ b0, of 0] ‹b ∈∘ A› show False by auto
    qed
    have cac''[intro, simp]: 
      "c ∈∘ C' ⟹ ⟨a, c⟩ ∈∘ T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈" for c
      unfolding eq[symmetric] C'_def B'_def 
      by (metis vcomp_vimage vimage_vsingleton_iff)
    define A'' where "A'' = (T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈) -`∘ C'"
    define B'' where "B'' = S⦇ArrVal⦈ `∘ set {a}"
    define C'' where "C'' = T⦇ArrVal⦈ `∘ B''"
    have a'': "a ∈∘ A''"
    proof-
      from ne_C' obtain c' where [intro]: "c' ∈∘ C'" 
        by (auto intro!: vsubset_antisym)
      then have "⟨a, c'⟩ ∈∘ T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈" by simp
      then show ?thesis unfolding A''_def by auto
    qed
    have "C' ⊆∘ C''"
      unfolding C''_def B''_def A''_def C'_def B'_def
      by (rule vsubsetI) (metis eq vcomp_vimage)
    have "C' = C''"
    proof(rule ccontr)
      assume "C' ≠ C''"
      with ‹C' ⊆∘ C''› obtain c' where c': "c' ∈∘ C'' -∘ C'" 
        by (auto intro!: vsubset_antisym)
      then obtain b'' where "b'' ∈∘ B''" and "⟨b'', c'⟩ ∈∘ T⦇ArrVal⦈"
        unfolding C''_def by auto
      then have "⟨a, c'⟩ ∈∘ T⦇ArrVal⦈ ∘∘ R⦇ArrVal⦈" unfolding eq B''_def by auto
      with c' show False unfolding B'_def C'_def by auto
    qed
    then have "T⦇ArrVal⦈ `∘ B'' = T⦇ArrVal⦈ `∘ B'" by (simp add: C''_def C'_def)
    moreover have "B' ⊆∘ A" and "B'' ⊆∘ A"
      using R.arr_Rel_ArrVal_vrange S.arr_Rel_ArrVal_vrange         
      unfolding B'_def B''_def 
      by auto
    ultimately have "B'' = B'" by (simp add: assms(5))
    with ab have "b ∈∘ B''" unfolding B'_def ab_def by simp
    then show "ab ∈∘ S⦇ArrVal⦈" unfolding ab_def B''_def by simp
  qed
qed

lemma smc_Rel_is_monic_arrI:
  assumes "T : A ↦smc_Rel α B"  
    and "⋀y z X. ⟦ y ⊆∘ A; z ⊆∘ A; T⦇ArrVal⦈ `∘ y = X; T⦇ArrVal⦈ `∘ z = X ⟧ ⟹ 
      y = z"
  shows "T : A ↦monsmc_Rel α B"
proof(rule is_monic_arrI)

  interpret Rel: semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)

  fix R S A'
  assume prems: 
    "R : A' ↦smc_Rel α A" 
    "S : A' ↦smc_Rel α A"
    "T ∘Asmc_Rel α R = T ∘Asmc_Rel α S"

  interpret T: arr_Rel α T
    rewrites "T⦇ArrDom⦈ = A" and "T⦇ArrCod⦈ = B"
    using assms(1)
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
  interpret R: arr_Rel α R 
    rewrites [simp]: "R⦇ArrDom⦈ = A'" and [simp]: "R⦇ArrCod⦈ = A"
    using prems(1)
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
  interpret S: arr_Rel α S
    rewrites [simp]: "S⦇ArrDom⦈ = A'" and [simp]: "S⦇ArrCod⦈ = A"
    using prems(2)
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)

  from assms prems have 
    "R⦇ArrVal⦈ ⊆∘ S⦇ArrVal⦈" "S⦇ArrVal⦈ ⊆∘ R⦇ArrVal⦈" 
    by (auto simp: smc_Rel_is_monic_arr_vsubset)
  then show "R = S"
    using R.arr_Rel_axioms S.arr_Rel_axioms 
    by (intro arr_Rel_eqI[of α R S]) auto

qed (rule assms(1))

end

end

lemma (in 𝒵) smc_Rel_is_monic_arrD[dest]:
  assumes "T : A ↦monsmc_Rel α B"
    and "y ⊆∘ A"
    and "z ⊆∘ A" 
    and "T⦇ArrVal⦈ `∘ y = X" 
    and "T⦇ArrVal⦈ `∘ z = X" 
  shows "y = z"
proof-

  interpret Rel: semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)

  from assms have T: "T : A ↦smc_Rel α B" by (simp add: is_monic_arr_def)
  interpret T: arr_Rel α T
    rewrites "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
    using T
    by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
 
  define R where "R = [set {0} ×∘ y, set {0}, A]∘"
  define S where "S = [set {0} ×∘ z, set {0}, A]∘"
  
  have R: "R : set {0} ↦smc_Rel α A" 
  proof(intro smc_Rel_is_arrI)
    show "arr_Rel α R"
      unfolding R_def
    proof(intro arr_Rel_vfsequenceI)
      from assms(2) show "ℛ∘ (set {0} ×∘ y) ⊆∘ A" by auto
    qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
  qed (simp_all add: R_def arr_Rel_components)

  from assms(3) have S: "S : set {0} ↦smc_Rel α A"
  proof(intro smc_Rel_is_arrI)
    show "arr_Rel α S"
      unfolding S_def
    proof(intro arr_Rel_vfsequenceI)
      from assms(3) show "ℛ∘ (set {0} ×∘ z) ⊆∘ A" by auto
    qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
  qed (simp_all add: S_def arr_Rel_components)

  from assms(4) have "T ∘Asmc_Rel α R = [set {0} ×∘ X, set {0}, B]∘"
    unfolding smc_Rel_Comp_app[OF T R]
    unfolding comp_Rel_components R_def comp_Rel_def arr_Rel_components
    by (simp add: vcomp_vimage_vtimes_right)
  moreover from assms have "T ∘Asmc_Rel α S = [set {0} ×∘ X, set {0}, B]∘"
    unfolding smc_Rel_Comp_app[OF T S]
    unfolding comp_Rel_components S_def comp_Rel_def arr_Rel_components
    by (simp add: vcomp_vimage_vtimes_right)
  ultimately have "T ∘Asmc_Rel α R = T ∘Asmc_Rel α S" by simp
  from R S assms(1) this have "R = S" by (elim is_monic_arrE)
  then show "y = z" unfolding R_def S_def by auto

qed

lemma (in 𝒵) smc_Rel_is_monic_arr:
  "T : A ↦monsmc_Rel α B ⟷
    T : A ↦smc_Rel α B ∧
    (
      ∀y z X.
        y ⊆∘ A ⟶
        z ⊆∘ A ⟶
        (T⦇ArrVal⦈) `∘ y = X ⟶
        (T⦇ArrVal⦈) `∘ z = X ⟶
        y = z
    )"
  by (rule iffI allI impI) 
    (auto simp: smc_Rel_is_monic_arrD smc_Rel_is_monic_arrI)

lemma (in 𝒵) smc_Rel_is_monic_arr_is_epic_arr: 
  assumes "T : A ↦smc_Rel α B" 
    and "(†SMC.Rel α)⦇ArrMap⦈⦇T⦈ : B ↦monsmc_Rel α A"
  shows "T : A ↦epismc_Rel α B"
proof-

  interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†SMC.Rel α›
    rewrites "(op_smc ℭ')⦇Obj⦈ = ℭ'⦇Obj⦈" 
      and "(op_smc ℭ')⦇Arr⦈ = ℭ'⦇Arr⦈"
      and "f : b ↦op_smc ℭ' a ⟷ f : a ↦ℭ' b" 
      for ℭ' f a b
    unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
  
  show ?thesis
  proof(intro HomCod.is_epic_arrI)

    show T: "T : A ↦smc_Rel α B" by (rule assms(1))
  
    fix f g a assume prems: 
      "f : B ↦smc_Rel α a" 
      "g : B ↦smc_Rel α a" 
      "f ∘Asmc_Rel α T = g ∘Asmc_Rel α T" 
  
    from prems(1) have "†SMC.Rel α⦇ArrMap⦈⦇f⦈ :
      †SMC.Rel α⦇ObjMap⦈⦇a⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇B⦈"
      by (auto intro: smc_cs_intros)
    with prems(1) HomCod.smc_is_arrD(3) T have dag_f: 
      "†SMC.Rel α⦇ArrMap⦈⦇f⦈ : a ↦smc_Rel α B" 
      unfolding smcf_dag_Rel_components(1) by auto
    from prems(2) have "†SMC.Rel α⦇ArrMap⦈⦇g⦈ : 
      †SMC.Rel α⦇ObjMap⦈⦇a⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇B⦈"
      by (auto intro: smc_cs_intros)
    with prems(2) have dag_g: "†SMC.Rel α⦇ArrMap⦈⦇g⦈ : a ↦smc_Rel α B"
      unfolding smcf_dag_Rel_components(1) 
      by (metis HomCod.smc_is_arrD(3) T vid_on_eq_atI)
    from prems T have 
      "†SMC.Rel α⦇ArrMap⦈⦇T⦈ ∘Asmc_Rel α †SMC.Rel α⦇ArrMap⦈⦇f⦈ = 
        †SMC.Rel α⦇ArrMap⦈⦇T⦈ ∘Asmc_Rel α †SMC.Rel α⦇ArrMap⦈⦇g⦈"
      by (simp add: smcf_dag_Rel_ArrMap_smc_Rel_Comp[symmetric])
    from is_monic_arrD(2)[OF assms(2) dag_f dag_g this] show "f = g"
      by (meson prems HomDom.smc_is_arrD(1) ArrMap.v11_eq_iff)
  
  qed
qed

lemma (in 𝒵) smc_Rel_is_epic_arr_is_monic_arr:
  assumes "T : A ↦epismc_Rel α B" 
  shows "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : B ↦monsmc_Rel α A"
proof(rule is_monic_arrI)

  interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†SMC.Rel α› 
    rewrites "f : b ↦op_smc ℭ' a ⟷ f : a ↦ℭ' b" for ℭ' f a b
    unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)

  have dag: "†SMC.Rel α : op_smc (smc_Rel α) ↦↦SMCα smc_Rel α" 
    by (auto intro: smc_cs_intros)

  from HomCod.is_epic_arrD(1)[OF assms] have T: "T : A ↦smc_Rel α B".

  from T have "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : 
    †SMC.Rel α⦇ObjMap⦈⦇B⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇A⦈"
    by (auto intro: smc_cs_intros)
  with T show dag_T: "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : B ↦smc_Rel α A"
    unfolding smcf_dag_Rel_components(1)
    by (metis HomCod.smc_is_arrD(2) HomCod.smc_is_arrD(3) vid_on_eq_atI)

  fix f g a :: V
  assume prems:
    "f : a ↦smc_Rel α B" 
    "g : a ↦smc_Rel α B" 
    "†SMC.Rel α⦇ArrMap⦈⦇T⦈ ∘Asmc_Rel α f = †SMC.Rel α⦇ArrMap⦈⦇T⦈ ∘Asmc_Rel α g" 
  then have a: "a ∈∘ smc_Rel α⦇Obj⦈" by auto
  from prems(1) have "†SMC.Rel α⦇ArrMap⦈⦇f⦈ :
    †SMC.Rel α⦇ObjMap⦈⦇B⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇a⦈"
    by (auto intro: smc_cs_intros)
  with prems(1) have dag_f: "†SMC.Rel α⦇ArrMap⦈⦇f⦈ : B ↦smc_Rel α a"
    by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
  from prems(2) have "†SMC.Rel α⦇ArrMap⦈⦇g⦈ : 
    †SMC.Rel α⦇ObjMap⦈⦇B⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇a⦈"
    by (cs_concl cs_intro: smc_cs_intros cs_simp:)
  with prems(2) have dag_g: "†SMC.Rel α⦇ArrMap⦈⦇g⦈ : B ↦smc_Rel α a" 
    by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
  from T dag have 
    "†SMC.Rel α⦇ArrMap⦈⦇†SMC.Rel α⦇ArrMap⦈⦇T⦈⦈ =
      (†SMC.Rel α SMCF∘ †SMC.Rel α)⦇ArrMap⦈⦇T⦈"
    by
      (
        cs_concl
          cs_intro: smc_cs_intros 
          cs_simp: smc_Rel_cs_simps smc_cn_cs_simps smc_cs_simps
      )
  also from T have "… = T" 
    unfolding dghm_id_components smcf_cn_comp_smcf_dag_Rel_smcf_dag_Rel by auto
  finally have dag_dag_T: "†SMC.Rel α⦇ArrMap⦈⦇†SMC.Rel α⦇ArrMap⦈⦇T⦈⦈ = T" by simp
  have 
    "†SMC.Rel α⦇ArrMap⦈⦇f⦈ ∘Asmc_Rel α T = †SMC.Rel α⦇ArrMap⦈⦇g⦈ ∘Asmc_Rel α T"
    by (metis dag_T dag_dag_T prems smcf_dag_Rel_ArrMap_smc_Rel_Comp)
  from HomCod.is_epic_arrD(2)[OF assms dag_f dag_g this] prems ArrMap.v11_eq_iff
  show "f = g"
    by blast

qed

lemma (in 𝒵) smc_Rel_is_epic_arrI:
  assumes "T : A ↦smc_Rel α B"  
    and "⋀y z X. ⟦ y ⊆∘ B; z ⊆∘ B; T⦇ArrVal⦈ -`∘ y = X; T⦇ArrVal⦈ -`∘ z = X ⟧ ⟹
      y = z"
  shows "T : A ↦epismc_Rel α B"
proof-
  interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†SMC.Rel α› 
    rewrites "f : b ↦op_smc ℭ' a ⟷ f : a ↦ℭ' b" for ℭ' f a b 
    unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
  from assms have T: "arr_Rel α T" by (auto simp: smc_Rel_is_arrD(1))
  have "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : B ↦monsmc_Rel α A"
  proof(rule smc_Rel_is_monic_arrI)
    from assms(1) have "†SMC.Rel α⦇ArrMap⦈⦇T⦈ :
      †SMC.Rel α⦇ObjMap⦈⦇B⦈ ↦smc_Rel α †SMC.Rel α⦇ObjMap⦈⦇A⦈"
      by (cs_concl cs_intro: smc_cs_intros)
    with assms(1) show "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : B ↦smc_Rel α A"
      by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
    fix y z X
    assume
      "y ⊆∘ B"
      "z ⊆∘ B" 
      "†SMC.Rel α⦇ArrMap⦈⦇T⦈⦇ArrVal⦈ `∘ y = X" 
      "†SMC.Rel α⦇ArrMap⦈⦇T⦈⦇ArrVal⦈ `∘ z = X" 
    then show "y = z"
      unfolding 
        converse_Rel_components 
        smcf_dag_Rel_ArrMap_app[OF T] 
        app_invimage_def[symmetric]
      by (rule assms(2))
  qed
  from smc_Rel_is_monic_arr_is_epic_arr[OF assms(1) this] show ?thesis by simp
qed

lemma (in 𝒵) smc_Rel_is_epic_arrD[dest]:
  assumes "T : A ↦epismc_Rel α B"
    and "y ⊆∘ B"
    and "z ⊆∘ B" 
    and "T⦇ArrVal⦈ -`∘ y = X" 
    and "T⦇ArrVal⦈ -`∘ z = X" 
  shows "y = z"
proof-
  interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†SMC.Rel α› 
    rewrites "f : b ↦op_smc ℭ' a ⟷ f : a ↦ℭ' b" 
    for ℭ' f a b 
    unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
  have dag_T: "†SMC.Rel α⦇ArrMap⦈⦇T⦈ : B ↦monsmc_Rel α A"
    by (rule smc_Rel_is_epic_arr_is_monic_arr[OF assms(1)])
  from HomCod.is_epic_arrD(1)[OF assms(1)] have T: "T : A ↦smc_Rel α B".
  then have T: "arr_Rel α T" by (auto simp: smc_Rel_is_arrD(1))
  from 
    assms(4,5) 
    smc_Rel_is_monic_arrD
      [
        OF dag_T assms(2,3), 
        unfolded 
          smc_dg_smc_Rel 
          smcf_dghm_smcf_dag_Rel 
          converse_Rel_components 
          smcf_dag_Rel_ArrMap_app[OF T]
      ]
  show ?thesis
    by (auto simp: app_invimage_def)
qed

lemma (in 𝒵) smc_Rel_is_epic_arr:
  "T : A ↦epismc_Rel α B ⟷
    T : A ↦smc_Rel α B ∧ 
      (
        ∀y z X.
          y ⊆∘ B ⟶
          z ⊆∘ B ⟶
          T⦇ArrVal⦈ -`∘ y = X ⟶
          T⦇ArrVal⦈ -`∘ z = X ⟶
          y = z
      )"
proof(intro iffI allI impI conjI)
  show "T : A ↦epismc_Rel α B ⟹ T : A ↦smc_Rel α B"
    by (simp add: is_epic_arr_def is_monic_arr_def op_smc_is_arr)
qed (auto simp: smc_Rel_is_epic_arrI)



subsection‹Terminal object, initial object and null object›


text‹
An object in the semicategory ‹Rel› is terminal/initial/null if and only if 
it is the empty set (see
nLab \cite{noauthor_nlab_nodate})\footnote{
\url{https://ncatlab.org/nlab/show/database+of+categories}
}. 
›

lemma (in 𝒵) smc_Rel_obj_terminal: "obj_terminal (smc_Rel α) A ⟷ A = 0"
proof-

  interpret semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)

  have "(∀A∈∘Vset α. ∃!T. T : A ↦smc_Rel α B) ⟷ B = 0" for B
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "∀A∈∘Vset α. ∃!T. T : A ↦smc_Rel α B"

    then obtain T where "T : 0 ↦smc_Rel α B" by (meson vempty_is_zet)
    then have [simp]: "B ∈∘ Vset α" by (fastforce simp: smc_Rel_components(1))
    
    show "B = 0"
    proof(rule ccontr)
      assume "B ≠ 0"
      with trad_foundation obtain b where "b ∈∘ B" by auto
      let ?b0B = ‹[set {⟨0, b⟩}, set {0}, B]∘›
      let ?z0B = ‹[0, set {0}, B]∘›
      have "?b0B : set {0} ↦smc_Rel α B"
      proof(intro smc_Rel_is_arrI)
        show b0B: "arr_Rel α ?b0B"
          by (intro arr_Rel_vfsequenceI)
            (force simp: ‹b ∈∘ B› vsubset_vsingleton_leftI)+
      qed (simp_all add: arr_Rel_components)
      moreover have "?z0B : set {0} ↦smc_Rel α B"
      proof(intro smc_Rel_is_arrI)
        show b0B: "arr_Rel α ?z0B"
          by (intro arr_Rel_vfsequenceI)
            (force simp: ‹b ∈∘ B› vsubset_vsingleton_leftI)+
      qed (simp_all add: arr_Rel_components)
      moreover have "[set {⟨0, b⟩}, set {0}, B]∘ ≠ [0, set {0}, B]∘" by simp
      ultimately show False  
        by (metis prems smc_is_arrE smc_Rel_components(1))
    qed

  next

    fix A assume prems[simp]: "B = 0" "A ∈∘ Vset α" 
    let ?zAz = ‹[0, A, 0]∘›
    have zAz: "arr_Rel α ?zAz"
      by 
        (
          simp add: 
            𝒵.arr_Rel_vfsequenceI 
            𝒵_axioms 
            smc_Rel_components(2) 
            vbrelation_vempty
        )

    show "∃!T. T : A ↦smc_Rel α B"
    proof(rule ex1I[of _ ‹?zAz›])
      show "?zAz : A ↦smc_Rel α B"
        by (intro smc_Rel_is_arrI)
          (
            simp_all add: 
              zAz 
              smc_Rel_Dom_app[OF zAz] 
              smc_Rel_Cod_app[OF zAz] 
              arr_Rel_components
          )      
      fix T assume "T : A ↦smc_Rel α B"
      then have T: "T : A ↦smc_Rel α 0" by simp
      then interpret T: arr_Rel α T by (fastforce simp: smc_Rel_components(2))
      show "T = [0, A, 0]∘"
      proof
        (
          subst T.arr_Rel_def, 
          rule arr_Rel_eqI[of α], 
          unfold arr_Rel_components
        )
        show "arr_Rel α [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘"
          by (fold T.arr_Rel_def) (simp add: T.arr_Rel_axioms)
        from zAz show "arr_Rel α ?zAz" 
          by (simp add: arr_Rel_vfsequenceI vbrelationI)
        from T have "T ∈∘ smc_Rel α⦇Arr⦈" by (auto intro: smc_cs_intros)
        with is_arrD(2,3)[OF T] show "T⦇ArrDom⦈ = A" "T⦇ArrCod⦈ = 0"
          using T smc_Rel_is_arrD(2,3) by auto
        with T.arr_Rel_ArrVal_vrange T.ArrVal.vbrelation_vintersection_vrange 
        show "T⦇ArrVal⦈ = []∘"
          by auto
      qed

    qed

  qed

  then show ?thesis
    apply(intro iffI obj_terminalI)
    subgoal by (metis smc_is_arrD(2) obj_terminalE)
    subgoal by blast
    subgoal by (metis smc_Rel_components(1))
    done

qed

(*TODO: generalize: duality/dagger*)
lemma (in 𝒵) smc_Rel_obj_initial: "obj_initial (smc_Rel α) A ⟷ A = 0"
proof-

  interpret semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)

  have "(∀B∈∘Vset α. ∃!T. T : A ↦smc_Rel α B) ⟷ A = 0" for A
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "∀B∈∘Vset α. ∃!T. T : A ↦smc_Rel α B" 

    then obtain T where TA0: "T : A ↦smc_Rel α 0" by (meson vempty_is_zet)
    then have [simp]: "A ∈∘ Vset α" by (fastforce simp: smc_Rel_components(1))

    show "A = 0"
    proof(rule ccontr)
      assume "A ≠ 0"
      with trad_foundation obtain a where "a ∈∘ A" by auto
      have "[set {⟨a, 0⟩}, A, set {0}]∘ : A ↦smc_Rel α set {0}"
      proof(intro smc_Rel_is_arrI)
        show "arr_Rel α [set {⟨a, 0⟩}, A, set {0}]∘"
          by (intro arr_Rel_vfsequenceI)
            (auto simp: ‹a ∈∘ A› vsubset_vsingleton_leftI)
      qed (simp_all add: arr_Rel_components)
      moreover have "[0, A, set {0}]∘ : A ↦smc_Rel α set {0}"
      proof(intro smc_Rel_is_arrI)
        show "arr_Rel α [0, A, set {0}]∘"
          by (intro arr_Rel_vfsequenceI)
            (auto simp: ‹a ∈∘ A› vsubset_vsingleton_leftI)
      qed (simp_all add: arr_Rel_components)
      moreover have "[set {⟨a, 0⟩}, A, set {0}]∘ ≠ [0, A, set {0}]∘" by simp
      ultimately show False
        by (metis prems smc_is_arrE smc_Rel_components(1))
    qed
  next

    fix B assume [simp]: "A = 0" "B ∈∘ Vset α" 
    show "∃!T. T : A ↦smc_Rel α B"
    proof(rule ex1I[of _ ‹[0, 0, B]∘›])
      show "[0, 0, B]∘ : A ↦smc_Rel α B"
        by (rule is_arrI)
          (
            simp_all add:
              smc_Rel_cs_simps
              smc_Rel_components(2) 
              vbrelation_vempty
              arr_Rel_vfsequenceI 
          )
      fix T assume "T : A ↦smc_Rel α B"
      then have T: "T : 0 ↦smc_Rel α B" by simp
      interpret T: arr_Rel α T 
        using T by (fastforce simp: smc_Rel_components(2))
      show "T = [0, 0, B]∘"
      proof
        (
          subst T.arr_Rel_def, 
          rule arr_Rel_eqI[of α], 
          unfold arr_Rel_components
        )
        show "arr_Rel α [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]∘"
          by (fold T.arr_Rel_def) (simp add: T.arr_Rel_axioms)
        show "arr_Rel α [[]∘, []∘, B]∘" 
          by (simp add: arr_Rel_vfsequenceI vbrelationI)
        from T have "T ∈∘ smc_Rel α⦇Arr⦈" by (auto intro: smc_cs_intros)
        with T is_arrD(2,3)[OF T] show "T⦇ArrDom⦈ = 0" "T⦇ArrCod⦈ = B"
          by (auto simp: smc_Rel_is_arrD(2,3))
        with 
          T.arr_Rel_ArrVal_vrange 
          T.arr_Rel_ArrVal_vdomain 
          T.ArrVal.vbrelation_vintersection_vdomain
        show "T⦇ArrVal⦈ = []∘"
          by auto
      qed
    qed
  qed

  then show ?thesis
    apply(intro iffI obj_initialI, elim obj_initialE)
    subgoal by (metis smc_Rel_components(1))
    subgoal by (simp add: smc_Rel_components(1))
    subgoal by (metis smc_Rel_components(1))
    done

qed

lemma (in 𝒵) smc_Rel_obj_terminal_obj_initial:
  "obj_initial (smc_Rel α) A ⟷ obj_terminal (smc_Rel α) A"
  unfolding smc_Rel_obj_initial smc_Rel_obj_terminal by simp

lemma (in 𝒵) smc_Rel_obj_null: "obj_null (smc_Rel α) A ⟷ A = 0"
  unfolding obj_null_def smc_Rel_obj_terminal smc_Rel_obj_initial by simp



subsection‹Zero arrow›


text‹
A zero arrow for ‹Rel› is any admissible ‹V›-arrow, such that its value 
is the empty set. A reference for this result is not given, but the 
result is not expected to be original.
›

lemma (in 𝒵) smc_Rel_is_zero_arr: 
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α"
  shows "T : A ↦0smc_Rel α B ⟷ T = [0, A, B]∘"
proof(rule HOL.ext iffI)

  interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
  
  fix T A B assume "T : A ↦0smc_Rel α B"
  then obtain R S
    where T_def: "T = R ∘Asmc_Rel α S" 
      and S: "S : A ↦smc_Rel α 0" 
      and R: "R : 0 ↦smc_Rel α B"
    by (elim is_zero_arrE) (simp add: obj_null_def smc_Rel_obj_terminal)

  interpret S: arr_Rel α S
    rewrites [simp]: "S⦇ArrDom⦈ = A" and [simp]: "S⦇ArrCod⦈ = 0"
    using S by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
  interpret R: arr_Rel α R
    rewrites [simp]: "R⦇ArrDom⦈ = 0" and [simp]: "R⦇ArrCod⦈ = B"
    using R by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)

  have S_def: "S = [0, A, 0]∘"   
    by 
      (
        rule arr_Rel_eqI[of α], 
        unfold arr_Rel_components,
        insert S.arr_Rel_ArrVal_vrange S.ArrVal.vbrelation_vintersection_vrange
      )
      (
        auto simp: 
          S.arr_Rel_axioms 
          S.arr_Rel_ArrDom_in_Vset 
          arr_Rel_vfsequenceI 
          vbrelationI
      )
  show "T = [0, A, B]∘" 
     unfolding T_def smc_Rel_Comp_app[OF R S] 
     by (rule arr_Rel_eqI[of α], unfold comp_Rel_components)
       (
         auto simp: 
          S_def 
          𝒵_axioms
          R.arr_Rel_axioms 
          S.arr_Rel_axioms 
          arr_Rel_comp_Rel
          arr_Rel_components
          R.arr_Rel_ArrCod_in_Vset 
          S.arr_Rel_ArrDom_in_Vset 
          𝒵.arr_Rel_vfsequenceI 
          vbrelation_vempty
       )

next

  assume prems: "T = [0, A, B]∘"
  let ?S = ‹[0, A, 0]∘› and ?R = ‹[0, 0, B]∘›
  have S: "arr_Rel α ?S" and R: "arr_Rel α ?R" 
    by (all‹intro arr_Rel_vfsequenceI›) (auto simp: assms)
  have SA0: "?S : A ↦smc_Rel α 0"
    by (intro smc_Rel_is_arrI) (simp_all add: S arr_Rel_components)
  moreover have R0B: "?R : 0 ↦smc_Rel α B"
    by (intro smc_Rel_is_arrI) (simp_all add: R arr_Rel_components)
  moreover have "T = ?R ∘Asmc_Rel α ?S" 
    unfolding smc_Rel_Comp_app[OF R0B SA0]
  proof(rule arr_Rel_eqI, unfold comp_Rel_components arr_Rel_components prems)
    show "arr_Rel α [0, A, B]∘"
      unfolding prems by (intro arr_Rel_vfsequenceI) (auto simp: assms)
  qed (use R S in ‹auto simp: smc_Rel_cs_intros›)
  ultimately show "T : A ↦0smc_Rel α B" 
    by (simp add: is_zero_arrI smc_Rel_obj_null)

qed

text‹\newpage›

end

Theory CZH_SMC_Par

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Par› as a semicategory›
theory CZH_SMC_Par
  imports 
    CZH_DG_Par
    CZH_SMC_Rel
    CZH_SMC_Subsemicategory
begin



subsection‹Background›


text‹
The methodology chosen for the exposition 
of ‹Par› as a semicategory is analogous to the 
one used in the previous chapter for the exposition of ‹Par› as a digraph. 
›

named_theorems smc_Par_cs_simps
named_theorems smc_Par_cs_intros

lemmas (in arr_Par) [smc_Par_cs_simps] = 
  dg_Rel_shared_cs_simps

lemmas [smc_Par_cs_simps] = 
  dg_Rel_shared_cs_simps
  arr_Par.arr_Par_length
  arr_Par_comp_Par_id_Par_left
  arr_Par_comp_Par_id_Par_right

lemmas [smc_Par_cs_intros] = 
  dg_Rel_shared_cs_intros
  arr_Par_comp_Par



subsection‹‹Par› as a semicategory›


subsubsection‹Definition and elementary properties›

definition smc_Par :: "V ⇒ V"
  where "smc_Par α =
    [
      Vset α,
      set {T. arr_Par α T},
      (λT∈∘set {T. arr_Par α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Par α T}. T⦇ArrCod⦈),
      (λST∈∘composable_arrs (dg_Par α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)
    ]∘"


text‹Components.›

lemma smc_Par_components:
  shows "smc_Par α⦇Obj⦈ = Vset α"
    and "smc_Par α⦇Arr⦈ = set {T. arr_Par α T}"
    and "smc_Par α⦇Dom⦈ = (λT∈∘set {T. arr_Par α T}. T⦇ArrDom⦈)"
    and "smc_Par α⦇Cod⦈ = (λT∈∘set {T. arr_Par α T}. T⦇ArrCod⦈)"
    and "smc_Par α⦇Comp⦈ = (λST∈∘composable_arrs (dg_Par α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Par_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_smc_Par: "smc_dg (smc_Par α) = dg_Par α"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ (smc_dg (smc_Par α)) = 4ℕ" 
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (dg_Par α) = 4ℕ"
    unfolding dg_Par_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smc_dg (smc_Par α)) = 𝒟∘ (dg_Par α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smc_dg (smc_Par α)) ⟹ smc_dg (smc_Par α)⦇a⦈ = dg_Par α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral, 
        unfold smc_dg_def dg_field_simps smc_Par_def dg_Par_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: dg_Par_def smc_dg_def)

lemmas_with [folded smc_dg_smc_Par, unfolded slicing_simps]: 
  smc_Par_Obj_iff = dg_Par_Obj_iff
  and smc_Par_Arr_iff[smc_Par_cs_simps] = dg_Par_Arr_iff
  and smc_Par_Dom_vsv[smc_Par_cs_intros] = dg_Par_Dom_vsv
  and smc_Par_Dom_vdomain[smc_Par_cs_simps] = dg_Par_Dom_vdomain
  and smc_Par_Dom_vrange = dg_Par_Dom_vrange
  and smc_Par_Dom_app[smc_Par_cs_simps] = dg_Par_Dom_app
  and smc_Par_Cod_vsv[smc_Par_cs_intros] = dg_Par_Cod_vsv
  and smc_Par_Cod_vdomain[smc_Par_cs_simps] = dg_Par_Cod_vdomain
  and smc_Par_Cod_vrange = dg_Par_Cod_vrange
  and smc_Par_Cod_app[smc_Par_cs_simps] = dg_Par_Cod_app
  and smc_Par_is_arrI = dg_Par_is_arrI
  and smc_Par_is_arrD = dg_Par_is_arrD
  and smc_Par_is_arrE = dg_Par_is_arrE

lemmas [smc_cs_simps] = smc_Par_is_arrD(2,3)

lemmas [smc_Par_cs_intros] = smc_Par_is_arrI

lemmas_with (in 𝒵) [folded smc_dg_smc_Par, unfolded slicing_simps]: 
  smc_Par_Hom_vifunion_in_Vset = dg_Par_Hom_vifunion_in_Vset
  and smc_Par_incl_Par_is_arr = dg_Par_incl_Par_is_arr
  and smc_Par_incl_Par_is_arr'[smc_Par_cs_intros] = dg_Par_incl_Par_is_arr'

lemmas [smc_Par_cs_intros] = 𝒵.smc_Par_incl_Par_is_arr'


subsubsection‹Composable arrows›

lemma smc_Par_composable_arrs_dg_Par: 
  "composable_arrs (dg_Par α) = composable_arrs (smc_Par α)"
  unfolding composable_arrs_def smc_dg_smc_Par[symmetric] slicing_simps by simp

lemma smc_Par_Comp: 
  "smc_Par α⦇Comp⦈ = (λST∈∘composable_arrs (smc_Par α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Par_components smc_Par_composable_arrs_dg_Par ..


subsubsection‹Composition›

lemma smc_Par_Comp_app[smc_Par_cs_simps]:
  assumes "S : B ↦smc_Par α C" and "T : A ↦smc_Par α B"
  shows "S ∘Asmc_Par α T = S ∘Rel T"
proof-
  from assms have "[S, T]∘ ∈∘ composable_arrs (smc_Par α)" 
    by (auto simp: smc_cs_intros)
  then show "S ∘Asmc_Par α T = S ∘Rel T"
    unfolding smc_Par_Comp by (simp add: nat_omega_simps)
qed 

lemma smc_Par_Comp_vdomain: "𝒟∘ (smc_Par α⦇Comp⦈) = composable_arrs (smc_Par α)" 
  unfolding smc_Par_Comp by simp

lemma (in 𝒵) smc_Par_Comp_vrange: "ℛ∘ (smc_Par α⦇Comp⦈) ⊆∘ set {T. arr_Par α T}"
proof(rule vsubsetI)
  interpret digraph α ‹smc_dg (smc_Par α)›
    unfolding smc_dg_smc_Par by (simp add: digraph_dg_Par)
  fix R assume "R ∈∘ ℛ∘ (smc_Par α⦇Comp⦈)"
  then obtain ST 
    where R_def: "R = smc_Par α⦇Comp⦈⦇ST⦈"
      and "ST ∈∘ 𝒟∘ (smc_Par α⦇Comp⦈)"
    unfolding smc_Par_components by (blast dest: rel_VLambda.vrange_atD)
  then obtain S T A B C 
    where "ST = [S, T]∘" 
      and S: "S : B ↦smc_Par α C" 
      and T: "T : A ↦smc_Par α B"
    by (auto simp: smc_Par_Comp_vdomain)
  with R_def have R_def': "R = S ∘Asmc_Par α T" by simp
  note S_D = dg_is_arrD(1)[unfolded slicing_simps, OF S]
    and T_D = dg_is_arrD(1)[unfolded slicing_simps, OF T]
  from S_D T_D have "arr_Par α S" "arr_Par α T" 
    by (simp_all add: smc_Par_components)
  from this show "R ∈∘ set {T. arr_Par α T}" 
    unfolding R_def' smc_Par_Comp_app[OF S T] by (auto simp: arr_Par_comp_Par)
qed


subsubsection‹‹Par› is a semicategory›

lemma (in 𝒵) semicategory_smc_Par: "semicategory α (smc_Par α)"
proof(intro semicategoryI, unfold smc_dg_smc_Par)
  show "vfsequence (smc_Par α)" unfolding smc_Par_def by simp
  show "vcard (smc_Par α) = 5ℕ"
    unfolding smc_Par_def by (simp add: nat_omega_simps)
  show "(GF ∈∘ 𝒟∘ (smc_Par α⦇Comp⦈)) ⟷
    (∃G F B C A. GF = [G, F]∘ ∧ G : B ↦smc_Par α C ∧ F : A ↦smc_Par α B)"
    for GF
    unfolding smc_Par_Comp_vdomain by (auto intro: composable_arrsI)
  show [intro]: "G ∘Asmc_Par α F : A ↦smc_Par α C"
    if "G : B ↦smc_Par α C" and "F : A ↦smc_Par α B" for G B C F A
  proof-
    from that have "arr_Par α G" "arr_Par α F" by (auto elim: smc_Par_is_arrE)
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Par_cs_simps 
            cs_intro: smc_Par_cs_intros
        )
  qed 
  show "H ∘Asmc_Par α G ∘Asmc_Par α F = H ∘Asmc_Par α (G ∘Asmc_Par α F)"
    if "H : C ↦smc_Par α D" 
      and "G : B ↦smc_Par α C"
      and "F : A ↦smc_Par α B"
    for H C D G B F A
  proof-
    from that have "arr_Par α H" "arr_Par α G" "arr_Par α F" 
      by (auto simp: smc_Par_is_arrD)
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Par_cs_simps 
            cs_intro: smc_Par_cs_intros
        )
  qed
qed (auto simp: digraph_dg_Par smc_Par_components)


subsubsection‹‹Par› is a wide subsemicategory of ‹Rel››

lemma (in 𝒵) wide_subsemicategory_smc_Par_smc_Rel: 
  "smc_Par α ⊆SMC.wideα smc_Rel α"
proof-
  interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
  interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
  show ?thesis
  proof
    (
      intro wide_subsemicategoryI subsemicategoryI,
      unfold smc_dg_smc_Par smc_dg_smc_Rel
    )
    from wide_subdigraph_dg_Par_dg_Rel show wsd:
      "dg_Par α ⊆DGα dg_Rel α" "dg_Par α ⊆DG.wideα dg_Rel α"
      by auto
    interpret wide_subdigraph α ‹dg_Par α› ‹dg_Rel α› by (rule wsd(2))
    show "G ∘Asmc_Par α F = G ∘Asmc_Rel α F"
      if "G : B ↦smc_Par α C" and "F : A ↦smc_Par α B" for G B C F A
    proof-
      from that have "G : B ↦dg_Par α C" and "F : A ↦dg_Par α B" 
        by (cs_concl cs_simp: smc_dg_smc_Par[symmetric] cs_intro: slicing_intros)+
      then have "G : B ↦dg_Rel α C" and "F : A ↦dg_Rel α B" 
        by (cs_concl cs_intro: dg_sub_fw_cs_intros)+
      then have "G : B ↦smc_Rel α C" and "F : A ↦smc_Rel α B" 
        unfolding smc_dg_smc_Rel[symmetric] slicing_simps by simp_all
      from that this show "G ∘Asmc_Par α F = G ∘Asmc_Rel α F"
        by (cs_concl cs_simp: smc_Par_cs_simps smc_Rel_cs_simps)
    qed
  qed (auto simp: smc_cs_intros)
qed



subsection‹Monic arrow and epic arrow›

lemma (in 𝒵) smc_Par_is_monic_arrI[intro]:
  assumes "T : A ↦smc_Par α B" and "v11 (T⦇ArrVal⦈)" and "𝒟∘ (T⦇ArrVal⦈) = A"
  shows "T : A ↦monsmc_Par α B"
proof(intro is_monic_arrI)
  interpret Par_Rel: wide_subsemicategory α ‹smc_Par α› ‹smc_Rel α›
    by (rule wide_subsemicategory_smc_Par_smc_Rel)
  interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(2))
  show T: "T : A ↦smc_Par α B" by (rule assms(1))
  fix S R A'
  assume S: "S : A' ↦smc_Par α A" 
    and R: "R : A' ↦smc_Par α A"
    and TS_TR: "T ∘Asmc_Par α S = T ∘Asmc_Par α R"
  from assms(3) T Par_Rel.subsemicategory_axioms have "T : A ↦monsmc_Rel α B"
    by (intro smc_Rel_is_monic_arrI)
      (auto dest: v11.v11_vimage_vpsubset_neq elim!: smc_sub_fw_cs_intros)
  moreover from S Par_Rel.subsemicategory_axioms have "S : A' ↦smc_Rel α A"
    by (cs_concl cs_intro: smc_sub_fw_cs_intros)
  moreover from R Par_Rel.subsemicategory_axioms have "R : A' ↦smc_Rel α A" 
    by (cs_concl cs_intro: smc_sub_fw_cs_intros)
  moreover from T S R TS_TR Par_Rel.subsemicategory_axioms have 
    "T ∘Asmc_Rel α S = T ∘Asmc_Rel α R" 
    by (auto simp: smc_sub_bw_cs_simps)
  ultimately show "S = R" by (rule is_monic_arrD(2))
qed

lemma (in 𝒵) smc_Par_is_monic_arrD:
  assumes "T : A ↦monsmc_Par α B"
  shows "T : A ↦smc_Par α B" and "v11 (T⦇ArrVal⦈)" and "𝒟∘ (T⦇ArrVal⦈) = A"
proof-

  from assms show T: "T : A ↦smc_Par α B" by auto
  interpret T: arr_Par α T 
    rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
    using T by (auto dest: smc_Par_is_arrD)

  show "v11 (T⦇ArrVal⦈)"
  proof(intro v11I)

    show "vsv ((T⦇ArrVal⦈)¯∘)"
    proof(intro vsvI)

      fix a b c assume "⟨a, b⟩ ∈∘ (T⦇ArrVal⦈)¯∘" and "⟨a, c⟩ ∈∘ (T⦇ArrVal⦈)¯∘"

      then have bar: "⟨b, a⟩ ∈∘ T⦇ArrVal⦈" and car: "⟨c, a⟩ ∈∘ T⦇ArrVal⦈" by auto
      with T.arr_Rel_ArrVal_vdomain have [intro]: "b ∈∘ A" "c ∈∘ A" by auto

      define R where "R = [set {⟨0, b⟩}, set {0}, A]∘"
      define S where "S = [set {⟨0, c⟩}, set {0}, A]∘"

      have R_components: 
        "R⦇ArrVal⦈ = set {⟨0, b⟩}" "R⦇ArrDom⦈ = set {0}" "R⦇ArrCod⦈ = A"
        unfolding R_def by (simp_all add: arr_Rel_components)

      have S_components: 
        "S⦇ArrVal⦈ = set {⟨0, c⟩}" "S⦇ArrDom⦈ = set {0}" "S⦇ArrCod⦈ = A"
        unfolding S_def by (simp_all add: arr_Rel_components)

      have R: "R : set {0} ↦smc_Par α A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par α R"
          unfolding R_def
          by (rule arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: R_components)

      have S: "S : set {0} ↦smc_Par α A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par α S"
          unfolding S_def
          by (rule arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: S_components)

      have "T ∘Asmc_Par α R = [set {⟨0, a⟩}, set {0}, B]∘"
        unfolding smc_Par_Comp_app[OF T R]
      proof
        (
          rule arr_Par_eqI[of α],
          unfold comp_Rel_components arr_Rel_components R_components
        )
        from R T show "arr_Par α (T ∘Rel R)"
          by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
        show "arr_Par α [set {⟨0, a⟩}, set {0}, B]∘"
        proof(rule arr_Par_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "ℛ∘ (set {⟨0, a⟩}) ⊆∘ B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
        show "T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩} = set {⟨0, a⟩}"
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from bar show "𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩}) = set {0}" by auto
          with bar show 
            "a' ∈∘ 𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩}) ⟹
              (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed simp_all

      moreover have "T ∘Asmc_Par α S = [set {⟨0, a⟩}, set {0}, B]∘" 
        unfolding smc_Par_Comp_app[OF T S]
      proof
        (
          rule arr_Par_eqI[of α],
          unfold comp_Rel_components arr_Rel_components S_components
        )
        from T S show "arr_Par α (T ∘Rel S)"
          by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
        show "arr_Par α [set {⟨0, a⟩}, set {0}, B]∘"
        proof(rule arr_Par_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "ℛ∘ (set {⟨0, a⟩}) ⊆∘ B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
        show "T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩} = set {⟨0, a⟩}"
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from car show "𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩}) = set {0}" by auto
          with car show "a' ∈∘ 𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩}) ⟹ 
            (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed simp_all
      ultimately have "T ∘Asmc_Par α R = T ∘Asmc_Par α S" by simp
      from assms R S this have "R = S" by blast
      with R_components(1) S_components(1) show "b = c" by simp
    qed auto

  qed auto

  show "𝒟∘ (T⦇ArrVal⦈) = A"
  proof(intro vsubset_antisym vsubsetI)
    from T.arr_Rel_ArrVal_vdomain show "x ∈∘ 𝒟∘ (T⦇ArrVal⦈) ⟹ x ∈∘ A" for x
      by auto
    fix a assume [simp]: "a ∈∘ A" show "a ∈∘ 𝒟∘ (T⦇ArrVal⦈)"
    proof(rule ccontr)
      assume a: "a ∉∘ 𝒟∘ (T⦇ArrVal⦈)"
      define R where "R = [set {⟨0, a⟩}, set {0, 1}, A]∘"
      define S where "S = [set {⟨1, a⟩}, set {0, 1}, A]∘"
      have R: "R : set {0, 1} ↦smc_Par α A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par α R"
          unfolding R_def
        proof(rule arr_Par_vfsequenceI)
          from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" 
            by blast
        qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (auto simp: R_def arr_Rel_components)
      have S: "S : set {0, 1} ↦smc_Par α A"
      proof(rule smc_Par_is_arrI)
        show "arr_Par α S"
          unfolding S_def
        proof(rule arr_Par_vfsequenceI)
          from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" 
            by blast
        qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (auto simp: S_def arr_Rel_components)
      with a have "T⦇ArrVal⦈ ∘∘ R⦇ArrVal⦈ = 0" 
        unfolding R_def arr_Rel_components
        by (intro vsubset_antisym vsubsetI) auto
      moreover with a have "T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈ = 0" 
        unfolding S_def arr_Rel_components
        by (intro vsubset_antisym vsubsetI) auto
      ultimately have "T ∘Asmc_Par α R = T ∘Asmc_Par α S" 
        using R T S
        by
          (
            intro arr_Par_eqI[of α ‹T ∘Asmc_Par α R› ‹T ∘Asmc_Par α S›]; 
            elim smc_Par_is_arrE
          )
          (
            auto simp:
              dg_Par_cs_intros
              smc_Par_Comp_app[OF T R] 
              smc_Par_Comp_app[OF T S] 
              comp_Rel_components
          )
      from R S this assms have "R = S" by blast
      then show False unfolding R_def S_def by simp
    qed 
  qed

qed 

lemma (in 𝒵) smc_Par_is_monic_arr: 
  "T : A ↦monsmc_Par α B ⟷
    T : A ↦smc_Par α B ∧ v11 (T⦇ArrVal⦈) ∧ 𝒟∘ (T⦇ArrVal⦈) = A"
  by (intro iffI) (auto simp: smc_Par_is_monic_arrD smc_Par_is_monic_arrI)

context 𝒵
begin

context
begin

private lemma smc_Par_is_epic_arr_vsubset:
  assumes "T : A ↦smc_Par α B"
    and "ℛ∘ (T⦇ArrVal⦈) = B"
    and "R : B ↦smc_Par α C" 
    and "S : B ↦smc_Par α C" 
    and "R ∘Asmc_Par α T = S ∘Asmc_Par α T" 
  shows "R⦇ArrVal⦈ ⊆∘ S⦇ArrVal⦈"
proof
  interpret T: arr_Par α T
    rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
    using assms smc_Par_is_arrD by auto
  interpret R: arr_Par α R 
    rewrites [simp]: "R⦇ArrDom⦈ = B" and [simp]: "R⦇ArrCod⦈ = C"
    using assms smc_Par_is_arrD by auto
  from assms(5) have "(R ∘Asmc_Par α T)⦇ArrVal⦈ = (S ∘Asmc_Par α T)⦇ArrVal⦈"
    by simp
  then have eq: "R⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈ = S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈" 
    unfolding 
      smc_Par_Comp_app[OF assms(3,1)] 
      smc_Par_Comp_app[OF assms(4,1)]
      comp_Rel_components
    by simp
  fix bc assume prems: "bc ∈∘ R⦇ArrVal⦈"
  moreover with R.ArrVal.vbrelation obtain b c where bc_def: "bc = ⟨b, c⟩" by auto
  ultimately have [simp]: "b ∈∘ B" and "c ∈∘ C"
    using R.arr_Rel_ArrVal_vdomain R.arr_Rel_ArrVal_vrange by auto
  note [intro] = prems[unfolded bc_def]
  have "b ∈∘ ℛ∘ (T⦇ArrVal⦈)" by (simp add: assms(2))
  then obtain a where ab: "⟨a, b⟩ ∈∘ T⦇ArrVal⦈" by auto
  then have "⟨a, c⟩ ∈∘ S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈" unfolding eq[symmetric] by auto
  then obtain b' where ab': "⟨b', c⟩ ∈∘ S⦇ArrVal⦈" and "⟨a, b'⟩ ∈∘ T⦇ArrVal⦈" 
    by clarsimp
  with ab ab' T.vsv T.ArrVal.vsv show "bc ∈∘ S⦇ArrVal⦈" unfolding bc_def by blast
qed

lemma smc_Par_is_epic_arrI:
  assumes "T : A ↦smc_Par α B" and "ℛ∘ (T⦇ArrVal⦈) = B"
  shows "T : A ↦epismc_Par α B"
  unfolding is_epic_arr_def
proof
  (
    intro is_monic_arrI[
      of ‹op_smc (smc_Par α)›, unfolded smc_op_simps, OF assms(1)
      ]
  )

  interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  fix R S a 
  assume prems: 
    "R : B ↦smc_Par α a" 
    "S : B ↦smc_Par α a" 
    "T ∘Aop_smc (smc_Par α) R = T ∘Aop_smc (smc_Par α) S"

  from prems(3) have RT_ST: "R ∘Asmc_Par α T = S ∘Asmc_Par α T"
    unfolding 
      op_smc_Comp[OF prems(1) assms(1)]
      op_smc_Comp[OF prems(2) assms(1)]
    by simp
  from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(1,2) this] 
  have RS: "R⦇ArrVal⦈ ⊆∘ S⦇ArrVal⦈".

  from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(2,1) RT_ST[symmetric]]
  have SR: "S⦇ArrVal⦈ ⊆∘ R⦇ArrVal⦈".
  
  from prems show "R = S"    
    by (intro arr_Par_eqI[of α R S])
      (auto simp: RS SR vsubset_antisym elim!: smc_Par_is_arrE)

qed

lemma smc_Par_is_epic_arrD:
  assumes "T : A ↦epismc_Par α B"
  shows "T : A ↦smc_Par α B" and "ℛ∘ (T⦇ArrVal⦈) = B"
proof-

  interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  from assms show T: "T : A ↦smc_Par α B" 
    unfolding is_epic_arr_def by (auto simp: op_smc_is_arr)

  interpret T: arr_Par α T
    rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
    using T by (auto elim: smc_Par_is_arrE)

  show "ℛ∘ (T⦇ArrVal⦈) = B"
  proof(intro vsubset_antisym vsubsetI)
    from T.arr_Rel_ArrVal_vrange show "y ∈∘ ℛ∘ (T⦇ArrVal⦈) ⟹ y ∈∘ B" for y
      by auto
    fix b assume [intro]: "b ∈∘ B" show "b ∈∘ ℛ∘ (T⦇ArrVal⦈)"
    proof(rule ccontr)
      assume prems: "b ∉∘ ℛ∘ (T⦇ArrVal⦈)"
      define R where "R = [set {⟨b, 0⟩}, B, set {0, 1}]∘"
      define S where "S = [set {⟨b, 1⟩}, B, set {0, 1}]∘"
      have R: "R : B ↦smc_Par α set {0, 1}" 
        unfolding R_def
      proof(intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
        from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" 
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      have S: "S : B ↦smc_Par α set {0, 1}"
        unfolding S_def
      proof(intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
        from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" 
          by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      from prems have "R⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈ = 0"
        unfolding R_def arr_Rel_components
        by (auto intro!: vsubset_antisym vsubsetI)
      moreover from prems have "S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈ = 0" 
        unfolding S_def arr_Rel_components
        by (auto intro!: vsubset_antisym vsubsetI)
      ultimately have "R ∘Asmc_Par α T = S ∘Asmc_Par α T" 
        unfolding smc_Par_Comp_app[OF R T] smc_Par_Comp_app[OF S T]
        by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
      from is_epic_arrD(2)[OF assms R S this] show False 
        unfolding R_def S_def by simp
    qed
  qed

qed

end

end

lemma (in 𝒵) smc_Par_is_epic_arr: 
  "T : A ↦epismc_Par α B ⟷ T : A ↦smc_Par α B ∧ ℛ∘ (T⦇ArrVal⦈) = B" 
  by (intro iffI) (simp_all add: smc_Par_is_epic_arrD smc_Par_is_epic_arrI)



subsection‹Terminal object, initial object and null object›

lemma (in 𝒵) smc_Par_obj_terminal: "obj_terminal (smc_Par α) A ⟷ A = 0"
proof-

  interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  have "(∀A∈∘Vset α. ∃!T. T : A ↦smc_Par α B) ⟷ B = 0" for B
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "∀A∈∘Vset α. ∃!T. T : A ↦smc_Par α B" 
    
    then obtain T where "T : 0 ↦smc_Par α B" by (meson vempty_is_zet)
    then have [simp]: "B ∈∘ Vset α" by (fastforce simp: smc_Par_components(1))
    
    show "B = 0"
    proof(rule ccontr)
      assume "B ≠ 0"
      then obtain b where "b ∈∘ B" using trad_foundation by auto
      have "[set {⟨0, b⟩}, set {0}, B]∘ : set {0} ↦smc_Par α B"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: ‹b ∈∘ B› vsubset_vsingleton_leftI)
      moreover have "[0, set {0}, B]∘ : set {0} ↦smc_Par α B"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: ‹b ∈∘ B› vsubset_vsingleton_leftI)
      moreover have "[set {⟨0, b⟩}, set {0}, B]∘ ≠ [0, set {0}, B]∘" by simp
      ultimately show False
        by (metis prems smc_is_arrE smc_Par_components(1))
    qed

  next

    fix A assume [simp]: "B = 0" "A ∈∘ Vset α"
    show "∃!T. T : A ↦smc_Par α B"
    proof(intro ex1I [of _ ‹[0, A, 0]∘›])
      show zAz: "[0, A, 0]∘ : A ↦smc_Par α B"
        by 
          ( 
            intro smc_Par_is_arrI arr_Par_vfsequenceI, 
            unfold arr_Rel_components
          ) 
          simp_all
      show "T = [0, A, 0]∘" if "T : A ↦smc_Par α B" for T
      proof(rule arr_Par_eqI[of α], unfold arr_Rel_components)
        interpret arr_Par α T using that by (simp add: smc_Par_is_arrD(1))
        from zAz show "arr_Par α [0, A, 0]∘" by (auto elim: smc_Par_is_arrE)
        from arr_Par_axioms that show "T⦇ArrVal⦈ = 0"
          by (clarsimp simp: vsv.vsv_vrange_vempty smc_Par_is_arrD(3))
      qed (use that in ‹auto dest: smc_Par_is_arrD›)
    qed

  qed

  then show ?thesis
    apply(intro iffI obj_terminalI)
    subgoal by (metis smc_is_arrD(2) obj_terminalE)
    subgoal by blast
    subgoal by (metis smc_Par_components(1))
    done

qed

lemma (in 𝒵) smc_Par_obj_initial: "obj_initial (smc_Par α) A ⟷ A = 0"
proof-

  interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  have "(∀B∈∘Vset α. ∃!T. T : A ↦smc_Par α B) ⟷ (A = 0)" for A
  proof(intro iffI allI ballI)

    assume prems[rule_format]: "∀B∈∘Vset α. ∃!T. T : A ↦smc_Par α B" 

    then obtain T where "T : A ↦smc_Par α 0" 
      by (meson vempty_is_zet)
    then have [simp]: "A ∈∘ Vset α" by (fastforce simp: smc_Par_components(1))

    show "A = 0"
    proof(rule ccontr)
      assume "A ≠ 0"
      then obtain a where "a ∈∘ A" using trad_foundation by auto
      have "[set {⟨a, 0⟩}, A, set {0}]∘ : A ↦smc_Par α set {0}"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: ‹a ∈∘ A› vsubset_vsingleton_leftI)
      moreover have "[0, A, set {0}]∘ : A ↦smc_Par α set {0}"
        by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
          (auto simp: ‹a ∈∘ A› vsubset_vsingleton_leftI)
      moreover have "[set {⟨a, 0⟩}, A, set {0}]∘ ≠ [0, A, set {0}]∘" by simp
      ultimately show False 
        by (metis prems Par.smc_is_arrE smc_Par_components(1))
    qed

  next

    fix B assume prems[simp]: "A = 0" "B ∈∘ Vset α"

    show "∃!T. T : A ↦smc_Par α B"
    proof(intro ex1I[of _ ‹[0, 0, B]∘›])
      show zzB: "[0, 0, B]∘ : A ↦smc_Par α B"
        by 
          ( 
            intro smc_Par_is_arrI arr_Par_vfsequenceI, 
            unfold arr_Rel_components
          ) 
          simp_all
      show "T = [0, 0, B]∘" if "T : A ↦smc_Par α B" for T
      proof(rule arr_Par_eqI[of α], unfold arr_Rel_components)
        interpret arr_Par α T using that by (simp add: smc_Par_is_arrD(1))
        show "arr_Par α T" by (rule arr_Par_axioms)
        from zzB show "arr_Par α [0, 0, B]∘" by (auto elim: smc_Par_is_arrE)
        from arr_Par_axioms that show "T⦇ArrVal⦈ = 0"
          by (elim smc_Par_is_arrE arr_ParE)
            (
              auto 
                intro: ArrVal.vsv_vrange_vempty 
                simp: ArrVal.vdomain_vrange_is_vempty
            )
      qed (use that in ‹auto dest: smc_Par_is_arrD›)
    qed
  qed

  then show ?thesis
    unfolding obj_initial_def
    apply(intro iffI obj_terminalI, elim obj_terminalE, unfold smc_op_simps)
    subgoal by (metis smc_Par_components(1))
    subgoal by (simp add: smc_Par_components(1))
    subgoal by (metis smc_Par_components(1))
    done

qed

lemma (in 𝒵) smc_Par_obj_terminal_obj_initial:
  "obj_initial (smc_Par α) A ⟷ obj_terminal (smc_Par α) A"
  unfolding smc_Par_obj_initial smc_Par_obj_terminal by simp

lemma (in 𝒵) smc_Par_obj_null: "obj_null (smc_Par α) A ⟷ A = 0"
  unfolding obj_null_def smc_Par_obj_terminal smc_Par_obj_initial by simp



subsection‹Zero arrow›

lemma (in 𝒵) smc_Par_is_zero_arr: 
  assumes "A ∈∘ Vset α" and "B ∈∘ Vset α"
  shows "T : A ↦0smc_Par α B ⟷ T = [0, A, B]∘"
proof(intro HOL.ext iffI)
  interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
  fix T A B assume "T : A ↦0smc_Par α B"
  with smc_Par_is_arrD(1) obtain R S 
    where T_def: "T = R ∘Asmc_Par α S" 
      and S: "S : A ↦smc_Par α 0" 
      and R: "R : 0 ↦smc_Par α B"
    by (auto simp: arr_Par_def 𝒵.smc_Par_obj_initial obj_null_def) 
  interpret S: arr_Par α S
    rewrites [simp]: "S⦇ArrDom⦈ = A" and [simp]: "S⦇ArrCod⦈ = 0"
    using S smc_Par_is_arrD by auto
  interpret R: arr_Par α R
    rewrites [simp]: "R⦇ArrDom⦈ = 0" and [simp]: "R⦇ArrCod⦈ = B"
    using R smc_Par_is_arrD by auto
  have S_def: "S = [0, A, 0]∘"
    by 
      (
        rule arr_Rel_eqI[of α], 
        unfold arr_Rel_components,
        insert S.arr_Rel_ArrVal_vrange S.ArrVal.vbrelation_vintersection_vrange
      )
      (
        auto simp: 
        S.arr_Rel_axioms 
        S.arr_Rel_ArrDom_in_Vset 
        arr_Rel_vfsequenceI vbrelationI
      )
  show "T = [0, A, B]∘" 
     unfolding T_def smc_Par_Comp_app[OF R S] 
     by (rule arr_Rel_eqI[of α], unfold comp_Rel_components)
       (
         auto simp: 
          𝒵_axioms
          S_def
          R.arr_Rel_axioms 
          S.arr_Rel_axioms 
          arr_Rel_comp_Rel
          arr_Rel_components
          R.arr_Rel_ArrCod_in_Vset 
          S.arr_Rel_ArrDom_in_Vset 
          𝒵.arr_Rel_vfsequenceI 
          vbrelation_vempty
       )
next
  fix T assume prems: "T = [0, A, B]∘"
  let ?S = ‹[0, A, 0]∘› and ?R = ‹[0, 0, B]∘›
  have S: "arr_Par α ?S" and R: "arr_Par α ?R"  
    by (all‹intro arr_Par_vfsequenceI›) (simp_all add: assms)
  have SA0: "?S : A ↦smc_Par α 0"
    by (intro smc_Par_is_arrI) (simp_all add: S arr_Rel_components)
  moreover have R0B: "?R : 0 ↦smc_Par α B"
    by (intro smc_Par_is_arrI) (simp_all add: R arr_Rel_components)
  moreover have "T = ?R ∘Asmc_Par α ?S" 
    unfolding smc_Par_Comp_app[OF R0B SA0]
  proof
    (
      rule arr_Par_eqI[of α],
      unfold comp_Rel_components arr_Rel_components prems
    )
    show "arr_Par α [0, A, B]∘"
      unfolding prems by (intro arr_Par_vfsequenceI) (auto simp: assms)
  qed (use R S in ‹auto simp: smc_Par_cs_intros›)
  ultimately show "T : A ↦0smc_Par α B" 
    by (simp add: is_zero_arrI smc_Par_obj_null)
qed

text‹\newpage›

end

Theory CZH_SMC_Set

(* Copyright 2021 (C) Mihails Milehins *)

section‹‹Set› as a semicategory›
theory CZH_SMC_Set
  imports 
    CZH_DG_Set
    CZH_SMC_Par
    CZH_SMC_Subsemicategory
begin



subsection‹Background›


text‹
The methodology chosen for the exposition 
of ‹Set› as a semicategory is analogous to the 
one used in the previous chapter for the exposition of ‹Set› as a digraph. 
›

named_theorems smc_Set_cs_simps
named_theorems smc_Set_cs_intros

lemmas (in arr_Set) [smc_Set_cs_simps] = 
  dg_Rel_shared_cs_simps

lemmas [smc_Set_cs_simps] =
  dg_Rel_shared_cs_simps
  arr_Set.arr_Set_ArrVal_vdomain
  arr_Set_comp_Set_id_Set_left
  arr_Set_comp_Set_id_Set_right

lemmas [smc_Set_cs_intros] = 
  dg_Rel_shared_cs_intros
  arr_Set_comp_Set



subsection‹‹Set› as a semicategory›


subsubsection‹Definition and elementary properties›

definition smc_Set :: "V ⇒ V"
  where "smc_Set α =
    [
      Vset α,
      set {T. arr_Set α T},
      (λT∈∘set {T. arr_Set α T}. T⦇ArrDom⦈),
      (λT∈∘set {T. arr_Set α T}. T⦇ArrCod⦈),
      (λST∈∘composable_arrs (dg_Set α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)
    ]∘"


text‹Components.›

lemma smc_Set_components:
  shows "smc_Set α⦇Obj⦈ = Vset α"
    and "smc_Set α⦇Arr⦈ = set {T. arr_Set α T}"
    and "smc_Set α⦇Dom⦈ = (λT∈∘set {T. arr_Set α T}. T⦇ArrDom⦈)"
    and "smc_Set α⦇Cod⦈ = (λT∈∘set {T. arr_Set α T}. T⦇ArrCod⦈)"
    and "smc_Set α⦇Comp⦈ = (λST∈∘composable_arrs (dg_Set α). ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Set_def dg_field_simps by (simp_all add: nat_omega_simps)


text‹Slicing.›

lemma smc_dg_smc_Set: "smc_dg (smc_Set α) = dg_Set α"
proof(rule vsv_eqI)
  have dom_lhs: "𝒟∘ (smc_dg (smc_Set α)) = 4ℕ" 
    unfolding smc_dg_def by (simp add: nat_omega_simps)
  have dom_rhs: "𝒟∘ (dg_Set α) = 4ℕ"
    unfolding dg_Set_def by (simp add: nat_omega_simps)
  show "𝒟∘ (smc_dg (smc_Set α)) = 𝒟∘ (dg_Set α)"
    unfolding dom_lhs dom_rhs by simp
  show "a ∈∘ 𝒟∘ (smc_dg (smc_Set α)) ⟹ smc_dg (smc_Set α)⦇a⦈ = dg_Set α⦇a⦈"
    for a
    by 
      (
        unfold dom_lhs, 
        elim_in_numeral,
        unfold smc_dg_def dg_field_simps smc_Set_def dg_Set_def
      )
      (auto simp: nat_omega_simps)
qed (auto simp: smc_dg_def dg_Set_def)

lemmas_with [folded smc_dg_smc_Set, unfolded slicing_simps]: 
  smc_Set_Obj_iff = dg_Set_Obj_iff
  and smc_Set_Arr_iff[smc_Set_cs_simps] = dg_Set_Arr_iff
  and smc_Set_Dom_vsv[smc_Set_cs_intros] = dg_Set_Dom_vsv
  and smc_Set_Dom_vdomain[smc_Set_cs_simps] = dg_Set_Dom_vdomain
  and smc_Set_Dom_vrange = dg_Set_Dom_vrange
  and smc_Set_Dom_app[smc_Set_cs_simps] = dg_Set_Dom_app
  and smc_Set_Cod_vsv[smc_Set_cs_intros] = dg_Set_Cod_vsv
  and smc_Set_Cod_vdomain[smc_Set_cs_simps] = dg_Set_Cod_vdomain
  and smc_Set_Cod_vrange = dg_Set_Cod_vrange
  and smc_Set_Cod_app[smc_Set_cs_simps] = dg_Set_Cod_app
  and smc_Set_is_arrI = dg_Set_is_arrI
  and smc_Set_is_arrD = dg_Set_is_arrD
  and smc_Set_is_arrE = dg_Set_is_arrE
  and smc_Set_ArrVal_vdomain[smc_Set_cs_simps] = dg_Set_ArrVal_vdomain
  and smc_Set_ArrVal_app_vrange[smc_Set_cs_intros] = dg_Set_ArrVal_app_vrange

lemmas [smc_cs_simps] = smc_Set_is_arrD(2,3)

lemmas_with (in 𝒵) [folded smc_dg_smc_Set, unfolded slicing_simps]: 
  smc_Set_Hom_vifunion_in_Vset = dg_Set_Hom_vifunion_in_Vset
  and smc_Set_incl_Set_is_arr = dg_Set_incl_Set_is_arr
  and smc_Set_incl_Set_is_arr'[smc_Set_cs_intros] = dg_Set_incl_Set_is_arr'

lemmas [smc_Set_cs_intros] = 
  smc_Set_is_arrI
  𝒵.smc_Set_incl_Set_is_arr'


subsubsection‹Composable arrows›

lemma smc_Set_composable_arrs_dg_Set: 
  "composable_arrs (dg_Set α) = composable_arrs (smc_Set α)"
  unfolding composable_arrs_def smc_dg_smc_Set[symmetric] slicing_simps by simp

lemma smc_Set_Comp: 
  "smc_Set α⦇Comp⦈ =
    VLambda (composable_arrs (smc_Set α)) (λST. ST⦇0⦈ ∘Rel ST⦇1ℕ⦈)"
  unfolding smc_Set_components smc_Set_composable_arrs_dg_Set ..


subsubsection‹Composition›

lemma smc_Set_Comp_app[smc_Set_cs_simps]:
  assumes "S : b ↦smc_Set α c" and "T : a ↦smc_Set α b"
  shows "S ∘Asmc_Set α T = S ∘Rel T"
proof-
  from assms have "[S, T]∘ ∈∘ composable_arrs (smc_Set α)" 
    by (auto simp: smc_cs_intros)
  then show "S ∘Asmc_Set α T = S ∘Rel T"
    unfolding smc_Set_Comp by (simp add: nat_omega_simps)
qed 

lemma smc_Set_Comp_vdomain: "𝒟∘ (smc_Set α⦇Comp⦈) = composable_arrs (smc_Set α)" 
  unfolding smc_Set_Comp by simp

lemma (in 𝒵) smc_Set_Comp_vrange: 
  "ℛ∘ (smc_Set α⦇Comp⦈) ⊆∘ set {T. arr_Set α T}"
proof(rule vsubsetI)
  interpret digraph α ‹smc_dg (smc_Set α)›
    unfolding smc_dg_smc_Set by (simp add: digraph_dg_Set)
  fix R assume "R ∈∘ ℛ∘ (smc_Set α⦇Comp⦈)"
  then obtain ST 
    where R_def: "R = smc_Set α⦇Comp⦈⦇ST⦈"
      and "ST ∈∘ 𝒟∘ (smc_Set α⦇Comp⦈)"
    unfolding smc_Set_components by (blast dest: rel_VLambda.vrange_atD) 
  then obtain S T a b c 
    where "ST = [S, T]∘" 
      and S: "S : b ↦smc_Set α c" 
      and T: "T : a ↦smc_Set α b"
    by (auto simp: smc_Set_Comp_vdomain)
  with R_def have R_def': "R = S ∘Asmc_Set α T" by simp
  interpret S: arr_Set α S + T: arr_Set α T 
    rewrites [simp]: "S⦇ArrDom⦈ = b" 
      and [simp]: "S⦇ArrCod⦈ = c"
      and [simp]: "T⦇ArrDom⦈ = a"
      and [simp]: "T⦇ArrCod⦈ = b"
    using S T by (auto elim!: smc_Set_is_arrD)
  have "ℛ∘ (T⦇ArrVal⦈) ⊆∘ 𝒟∘ (S⦇ArrVal⦈)"
  proof(intro vsubsetI)
    fix y assume prems: "y ∈∘ ℛ∘ (T⦇ArrVal⦈)"
    with T.ArrVal.vrange_atD obtain x 
      where y_def: "y = T⦇ArrVal⦈⦇x⦈" and x: "x ∈∘ 𝒟∘ (T⦇ArrVal⦈)"
      by metis
    from prems x T.arr_Set_ArrVal_vrange show "y ∈∘ 𝒟∘ (S⦇ArrVal⦈)"
      unfolding y_def by (auto simp: smc_Set_cs_simps)
  qed
  with S.arr_Set_axioms T.arr_Set_axioms have "arr_Set α (S ∘Rel T)"
    by (simp add: arr_Set_comp_Set)
  from this show "R ∈∘ set {T. arr_Set α T}" 
    unfolding R_def' smc_Set_Comp_app[OF S T] by simp
qed

lemma smc_Set_composable_vrange_vdomain[smc_Set_cs_intros]:
  assumes "g : b ↦smc_Set α c" and "f : a ↦smc_Set α b"
  shows "ℛ∘ (f⦇ArrVal⦈) ⊆∘ 𝒟∘ (g⦇ArrVal⦈)"
proof(intro vsubsetI)
  from assms have g: "arr_Set α g" and f: "arr_Set α f" 
    by (auto simp: smc_Set_is_arrD)
  fix y assume "y ∈∘ ℛ∘ (f⦇ArrVal⦈)"
  with assms f have "y ∈∘ b" by (force simp: smc_Set_is_arrD(3))
  with assms g show "y ∈∘ 𝒟∘ (g⦇ArrVal⦈)" 
    by (simp add: smc_Set_is_arrD(2) arr_SetD(5))
qed

lemma smc_Set_Comp_ArrVal[smc_cs_simps]:
  assumes "S : y ↦smc_Set α z" and "T : x ↦smc_Set α y" and "a ∈∘ x"
  shows "(S ∘Asmc_Set α T)⦇ArrVal⦈⦇a⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇a⦈⦈"
proof-
  interpret S: arr_Set α S + T: arr_Set α T
    using assms by (auto simp: smc_Set_is_arrD)
  have Ta: "T⦇ArrVal⦈⦇a⦈ ∈∘ y"
  proof-
    from assms have "a ∈∘ T⦇ArrDom⦈" by (auto simp: smc_Set_is_arrD)
    with assms T.arr_Set_ArrVal_vrange show ?thesis
      by 
        (
          simp add: 
            T.ArrVal.vsv_vimageI2 vsubset_iff smc_Set_is_arrD smc_Set_cs_simps
        )
  qed
  from Ta assms S.arr_Set_axioms T.arr_Set_axioms show ?thesis
    by ((cs_concl_step smc_Set_cs_simps)+, intro arr_Set_comp_Set_ArrVal[of α])
      (simp_all add: smc_Set_is_arrD smc_Set_cs_simps)
qed


subsubsection‹‹Set› is a semicategory›

lemma (in 𝒵) semicategory_smc_Set: "semicategory α (smc_Set α)"
proof(rule semicategoryI, unfold smc_dg_smc_Set)

  interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α› 
    by (rule wide_subdigraph_dg_Set_dg_Par)
  interpret smc_Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  show "vfsequence (smc_Set α)" unfolding smc_Set_def by simp
  show "vcard (smc_Set α) = 5ℕ"
    unfolding smc_Set_def by (simp add: nat_omega_simps)

  show "(gf ∈∘ 𝒟∘ (smc_Set α⦇Comp⦈)) ⟷ 
    (∃g f b c a. gf = [g, f]∘ ∧ g : b ↦smc_Set α c ∧ f : a ↦smc_Set α b)"
    for gf
    unfolding smc_Set_Comp_vdomain by (auto intro: composable_arrsI)

  show [intro]: "g ∘Asmc_Set α f : a ↦smc_Set α c"
    if "g : b ↦smc_Set α c" "f : a ↦smc_Set α b" for g b c f a
  proof-
    from that have g: "arr_Set α g" and f: "arr_Set α f" 
      by (auto simp: smc_Set_is_arrD)
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Set_cs_simps 
            cs_intro: smc_Set_cs_intros
        )
  qed
    
  show "h ∘Asmc_Set α g ∘Asmc_Set α f = h ∘Asmc_Set α (g ∘Asmc_Set α f)"
    if "h : c ↦smc_Set α d" 
      and "g : b ↦smc_Set α c"
      and "f : a ↦smc_Set α b"
    for h c d g b f a
  proof-
    from that have "arr_Set α h" "arr_Set α g" "arr_Set α f" 
      by (auto simp: smc_Set_is_arrD)
    with that show ?thesis
      by 
        (
          cs_concl 
            cs_simp: smc_cs_simps smc_Set_cs_simps 
            cs_intro: smc_Set_cs_intros
        )      
  qed

qed (auto simp: digraph_dg_Set smc_Set_components)


subsubsection‹‹Set› is a wide subsemicategory of ‹Par››

lemma (in 𝒵) wide_subsemicategory_smc_Set_smc_Par: 
  "smc_Set α ⊆SMC.wideα smc_Par α"
proof-
  interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
  interpret Set: semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
  show ?thesis
  proof
    (
      intro wide_subsemicategoryI subsemicategoryI, 
      unfold smc_dg_smc_Par smc_dg_smc_Set
    )
    from wide_subdigraph_dg_Set_dg_Par show wsd:  
      "dg_Set α ⊆DGα dg_Par α" 
      "dg_Set α ⊆DG.wideα dg_Par α"
      by auto
    interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α› by (rule wsd(2))
    show "g ∘Asmc_Set α f = g ∘Asmc_Par α f"
      if "g : b ↦smc_Set α c" and "f : a ↦smc_Set α b" for g b c f a
    proof-
      from that have "g : b ↦dg_Set α c" and "f : a ↦dg_Set α b" 
        by (cs_concl cs_simp: smc_dg_smc_Set[symmetric] cs_intro: slicing_intros)+
      then have "g : b ↦dg_Par α c" and "f : a ↦dg_Par α b" 
        by (cs_concl cs_intro: dg_sub_fw_cs_intros)+
      then have "g : b ↦smc_Par α c" and "f : a ↦smc_Par α b" 
        unfolding smc_dg_smc_Par[symmetric] slicing_simps by simp_all
      from that this show "g ∘Asmc_Set α f = g ∘Asmc_Par α f"
        by (cs_concl cs_simp: smc_Set_cs_simps smc_Par_cs_simps)
    qed
  qed (auto simp: smc_cs_intros)
qed



subsection‹Monic arrow and epic arrow›

lemma (in 𝒵) smc_Set_is_monic_arrI:
  ―‹See Chapter I-5 in \cite{mac_lane_categories_2010}).›
  assumes "T : A ↦smc_Set α B" and "v11 (T⦇ArrVal⦈)" and "𝒟∘ (T⦇ArrVal⦈) = A"
  shows "T : A ↦monsmc_Set α B"
proof(rule is_monic_arrI)
  interpret wide_subsemicategory α ‹smc_Set α› ‹smc_Par α›
    by (rule wide_subsemicategory_smc_Set_smc_Par)
  interpret v11 ‹T⦇ArrVal⦈› by (rule assms(2))
  show T: "T : A ↦smc_Set α B" by (rule assms(1))
  fix S R A'
  assume S: "S : A' ↦smc_Set α A" 
    and R: "R : A' ↦smc_Set α A" 
    and TS_TR: "T ∘Asmc_Set α S = T ∘Asmc_Set α R"
  from assms(3) T have "T : A ↦monsmc_Par α B" 
    by (intro smc_Par_is_monic_arrI) 
      (auto simp: v11_axioms dest: subsmc_is_arrD)
  moreover from S subsemicategory_axioms have "S : A' ↦smc_Par α A" 
    by (cs_concl cs_intro: smc_sub_fw_cs_intros)
  moreover from R subsemicategory_axioms have "R : A' ↦smc_Par α A" 
    by (cs_concl cs_intro: smc_sub_fw_cs_intros)
  moreover from T S R TS_TR subsemicategory_axioms have 
    "T ∘Asmc_Par α S = T ∘Asmc_Par α R" 
    by (auto simp: smc_sub_bw_cs_simps)
  ultimately show "S = R" by (rule is_monic_arrD(2))
qed

lemma (in 𝒵) smc_Set_is_monic_arrD:
  assumes "T : A ↦monsmc_Set α B"
  shows "T : A ↦smc_Set α B" and "v11 (T⦇ArrVal⦈)" and "𝒟∘ (T⦇ArrVal⦈) = A"
proof-

  interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α› 
    by (rule wide_subdigraph_dg_Set_dg_Par)
  interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)

  from assms show T: "T : A ↦smc_Set α B" by auto

  interpret T: arr_Set α T 
    rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
    using T by (auto elim!: smc_Set_is_arrE)
  
  show "v11 (T⦇ArrVal⦈)"
  proof(rule v11I)
  
    show "vsv ((T⦇ArrVal⦈)¯∘)"
    proof(rule vsvI)

      fix a b c assume "⟨a, b⟩ ∈∘ (T⦇ArrVal⦈)¯∘" and "⟨a, c⟩ ∈∘ (T⦇ArrVal⦈)¯∘"

      then have bar: "⟨b, a⟩ ∈∘ T⦇ArrVal⦈" and car: "⟨c, a⟩ ∈∘ T⦇ArrVal⦈"
        by auto
      with T.arr_Set_ArrVal_vdomain have [intro]: "b ∈∘ A" "c ∈∘ A" by blast+

      define R where "R = [set {⟨0, b⟩}, set {0}, A]∘"
      define S where "S = [set {⟨0, c⟩}, set {0}, A]∘"

      have R: "R : set {0} ↦smc_Set α A"
      proof(rule smc_Set_is_arrI)
        show "arr_Set α R"
          unfolding R_def
          by (rule arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: R_def arr_Rel_components)
      interpret R: arr_Set α R 
        rewrites [simp]: "R⦇ArrDom⦈ = set {0}" and [simp]: "R⦇ArrCod⦈ = A"
        using R by (auto elim!: smc_Set_is_arrE)

      have S: "S : set {0} ↦smc_Set α A"
      proof(rule smc_Set_is_arrI)
        show "arr_Set α S"
          unfolding S_def
          by (rule arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
      qed (simp_all add: S_def arr_Rel_components)
      interpret S: arr_Set α S 
        rewrites [simp]: "S⦇ArrDom⦈ = set {0}" and [simp]: "S⦇ArrCod⦈ = A"
        using S by (auto elim!: smc_Set_is_arrE)

      have "T ∘Asmc_Set α R = [set {⟨0, a⟩}, set {0}, B]∘"        
        unfolding smc_Set_Comp_app[OF T R]
      proof
        (
          rule arr_Set_eqI[of α], 
          unfold comp_Rel_components arr_Rel_components
        )
        from R T show "arr_Set α (T ∘Rel R)"
          by (intro arr_Set_comp_Set) 
            (auto elim!: smc_Set_is_arrE simp: smc_Set_cs_simps)
        show "arr_Set α [set {⟨0, a⟩}, set {0}, B]∘"
        proof(rule arr_Set_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "ℛ∘ (set {⟨0, a⟩}) ⊆∘ B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
        show "T⦇ArrVal⦈ ∘∘ R⦇ArrVal⦈ = set {⟨0, a⟩}"
          unfolding R_def arr_Rel_components
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from bar show "𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩}) = set {0}" by auto
          with bar show "a' ∈∘ 𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩}) ⟹ 
            (T⦇ArrVal⦈ ∘∘ set {⟨0, b⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed (simp_all add: R_def arr_Rel_components)
      moreover have "T ∘Asmc_Set α S = [set {⟨0, a⟩}, set {0}, B]∘" 
        unfolding smc_Set_Comp_app[OF T S]
      proof
        (
          rule arr_Set_eqI[of α],
          unfold comp_Rel_components arr_Rel_components
        )
        from T S show "arr_Set α (T ∘Rel S)"  
          by (intro arr_Set_comp_Set)
            (
              auto simp: 
                T.arr_Set_axioms 
                smc_Set_is_arrD 
                S.arr_Set_ArrVal_vrange 
                smc_Set_cs_simps
            )
        show "arr_Set α [set {⟨0, a⟩}, set {0}, B]∘"
        proof(rule arr_Set_vfsequenceI)
          from T.arr_Rel_ArrVal_vrange bar show "ℛ∘ (set {⟨0, a⟩}) ⊆∘ B" by auto
        qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
        show "T⦇ArrVal⦈ ∘∘ S⦇ArrVal⦈ = set {⟨0, a⟩}"
          unfolding S_def arr_Rel_components
        proof(rule vsv_eqI, unfold vdomain_vsingleton)
          from car show "𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩}) = set {0}" by auto
          with car show "a' ∈∘ 𝒟∘ (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩}) ⟹ 
            (T⦇ArrVal⦈ ∘∘ set {⟨0, c⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
            for a'
            by auto
        qed (auto intro: vsv_vcomp)
      qed (simp_all add: S_def arr_Rel_components)
      ultimately have "T ∘Asmc_Set α R = T ∘Asmc_Set α S" by simp
      from R S assms this have "R = S" by clarsimp
      then have "R⦇ArrVal⦈ = S⦇ArrVal⦈" by simp
      then show "b = c" unfolding R_def S_def arr_Rel_components by simp
    qed clarsimp

  qed auto

  show "𝒟∘ (T⦇ArrVal⦈) = A" by (simp add: smc_Set_cs_simps)

qed

lemma (in 𝒵) smc_Set_is_monic_arr: 
  "T : A ↦monsmc_Set α B ⟷  
    T : A ↦smc_Set α B ∧ v11 (T⦇ArrVal⦈) ∧ 𝒟∘ (T⦇ArrVal⦈) = A"
  by (rule iffI) (auto simp: smc_Set_is_monic_arrD smc_Set_is_monic_arrI)


text‹
An epic arrow in ‹Set› is a total surjective function (see Chapter I-5 
in \cite{mac_lane_categories_2010}).
›

lemma (in 𝒵) smc_Set_is_epic_arrI:
  assumes "T : A ↦smc_Set α B" and "ℛ∘ (T⦇ArrVal⦈) = B"
  shows "T : A ↦epismc_Set α B"
proof-
  interpret wide_subsemicategory α ‹smc_Set α› ‹smc_Par α›
    by (rule wide_subsemicategory_smc_Set_smc_Par)
  have epi_T: "T : A ↦epismc_Par α B"
    using assms by (meson smc_Par_is_epic_arr subsmc_is_arrD)
  show ?thesis
  proof(rule sdg.is_epic_arrI)
    show T: "T : A ↦smc_Set α B" by (rule assms(1))
    fix f g a
    assume prems: 
      "f : B ↦smc_Set α a" 
      "g : B ↦smc_Set α a"
      "f ∘Asmc_Set α T = g ∘Asmc_Set α T" 
    from prems(1) subsemicategory_axioms have "f : B ↦smc_Par α a" 
      by (cs_concl cs_intro: smc_sub_fw_cs_intros)
    moreover from prems(2) subsemicategory_axioms have "g : B ↦smc_Par α a" 
      by (cs_concl cs_intro: smc_sub_fw_cs_intros)
    moreover from prems T subsemicategory_axioms have 
      "f ∘Asmc_Par α T = g ∘Asmc_Par α T"
      by (auto simp: smc_sub_bw_cs_simps)
    ultimately show "f = g"
      by (rule dg.is_epic_arrD(2)[OF epi_T])
  qed
qed

lemma (in 𝒵) smc_Set_is_epic_arrD:
  assumes "T : A ↦epismc_Set α B"
  shows "T : A ↦smc_Set α B" and "ℛ∘ (T⦇ArrVal⦈) = B"
proof-

  interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)

  from assms show T: "T : A ↦smc_Set α B" by auto
  interpret T: arr_Set α T
    rewrites "T⦇ArrDom⦈ = A" and "T⦇ArrCod⦈ = B"
    using T by (auto elim!: smc_Set_is_arrE)
  show "ℛ∘ (T⦇ArrVal⦈) = B"
  proof(intro vsubset_antisym vsubsetI)
    fix b assume [intro]: "b ∈∘ B" 
    show "b ∈∘ ℛ∘ (T⦇ArrVal⦈)"
    proof(rule ccontr)
      assume b: "b ∉∘ ℛ∘ (T⦇ArrVal⦈)"
      define R 
        where "R = [vinsert ⟨b, 0⟩ ((B -∘ set {b}) ×∘ set {1}), B, set {0, 1}]∘"
      define S where "S = [B ×∘ set {1}, B, set {0, 1}]∘"
      have R: "R : B ↦smc_Set α set {0, 1}" 
        unfolding R_def
      proof(intro smc_Set_is_arrI arr_Set_vfsequenceI, unfold arr_Rel_components)
        from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      have S: "S : B ↦smc_Set α set {0, 1}"
        unfolding S_def
      proof(intro smc_Set_is_arrI arr_Set_vfsequenceI, unfold arr_Rel_components)
        from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈∘ Vset α" by blast
      qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
      from b have "R⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈ = S⦇ArrVal⦈ ∘∘ T⦇ArrVal⦈" 
        unfolding S_def R_def arr_Rel_components 
        by (auto intro!: vsubset_antisym vsubsetI)
      then have "R ∘Asmc_Set α T = S ∘Asmc_Set α T"
        unfolding smc_Set_Comp_app[OF R T] smc_Set_Comp_app[OF S T]
        by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
      from R S this have "R = S" by (rule is_epic_arrD(2)[OF assms])
      with zero_neq_one show False unfolding R_def S_def by blast
    qed
  qed (use T.arr_Set_ArrVal_vrange in auto)
qed

lemma (in 𝒵) smc_Set_is_epic_arr: 
  "T : A ↦epismc_Set α B ⟷ T : A ↦smc_Set α B ∧ ℛ∘ (T⦇ArrVal⦈) = B" 
  by (rule iffI) (simp_all add: smc_Set_is_epic_arrD smc_Set_is_epic_arrI)



subsection‹Terminal object, initial object and null object›


text‹An object in ‹Set› is terminal if and only if it is a singleton 
set (see Chapter I-5 in \cite{mac_lane_categories_2010}).›

lemma (in 𝒵) smc_Set_obj_terminal: 
  "obj_terminal (smc_Set α) A ⟷ (∃B∈∘Vset α. A = set {B})"
proof-

  interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
  
  have "(∀A∈∘Vset α. ∃!T. T : A ↦smc_Set α B) ⟷ (∃C∈∘Vset α. B = set {C})" 
    for B
  proof(intro iffI ballI)

    assume prems[rule_format]: "∀A∈∘Vset α. ∃!T. T : A ↦smc_Set α B"

    then obtain T where T0B: "T : 0 ↦smc_Set α B" by (meson vempty_is_zet)
    then have B[simp]: "B ∈∘ Vset α" by (fastforce simp: smc_Set_components(1))

    show "∃C∈∘Vset α. B = set {C}"
    proof(rule ccontr, cases ‹B = 0›)
      case True
      from prems have "∃!T. T : A ↦smc_Set α 0" if "A ∈∘ Vset α" for A
        using that unfolding True by simp
      then obtain T where T: "T : set {0} ↦smc_Set α 0" 
        by (metis Axiom_of_Pairing insert_absorb2 vempty_is_zet)
      interpret T: arr_Set α T
        rewrites "T⦇ArrDom⦈ = set {0}" and "T⦇ArrCod⦈ = 0"
        using T by (auto elim!: smc_Set_is_arrE)
      from 
        T.vdomain_vrange_is_vempty
        T.ArrVal.vdomain_vrange_is_vempty 
        T.arr_Set_ArrVal_vrange
      show False  
        by (auto simp: smc_Set_cs_simps)
    next
      case False 
      assume "¬(∃C∈∘Vset α. B = set {C})"
      with B have "∄C. B = set {C}" by blast
      with False obtain a b where ab: "a ≠ b" "a ∈∘ B" "b ∈∘ B"
        by (metis V_equalityI vemptyE vintersection_vsingleton vsingletonD)
      have "[set {⟨0, a⟩}, set {0}, B]∘ : set {0} ↦smc_Set α B"
        by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
          (auto simp: ab(2) nat_omega_simps)
      moreover from ab have 
        "[set {⟨0, b⟩}, set {0}, B]∘ : set {0} ↦smc_Set α B"
        by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
          (auto simp: ab(2) nat_omega_simps)
      moreover with ab have 
        "[set {⟨0, a⟩}, set {0}, B]∘ ≠ [set {⟨0, b⟩}, set {0}, B]∘"
        by simp
      ultimately show False
        by (metis prems smc_is_arrE smc_Set_components(1))
    qed
  next
    
    fix A assume prems: "∃b∈∘Vset α. B = set {b}" "A ∈∘ Vset α"
    then obtain b where B_def: "B = set {b}" and b: "b ∈∘ Vset α" by blast

    have "vconst_on A b = A ×∘ set {b}" by (simp add: vconst_on_eq_vtimes)

    show "∃!T. T : A ↦smc_Set α B"
      unfolding B_def
    proof(rule ex1I[of _ ‹[A ×∘ set {b}, A, set {b}]∘›])
      
      show "[A ×∘ set {b}, A, set {b}]∘ : A ↦smc_Set α set {b}"
        using b 
        by 
          ( 
            intro smc_Set_is_arrI arr_Set_vfsequenceI, 
            unfold arr_Rel_components
          )
          (auto simp: prems(2) vconst_on_eq_vtimes[symmetric])
      
      fix T assume prems: "T : A ↦smc_Set α set {b}"

      interpret T: arr_Set α T
        rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = set {b}"
        using prems by (auto elim!: smc_Set_is_arrE)

      have [simp]: "T⦇ArrVal⦈ = A ×∘ set {b}"
      proof(intro vsubset_antisym vsubsetI)
        fix x assume prems: "x ∈∘ T⦇ArrVal⦈"
        with T.vbrelation_axioms app_vdomainI obtain a b' 
          where "x = ⟨a, b'⟩" and "a ∈∘ A"
          by (metis T.ArrVal.vbrelation_vinE T.arr_Set_ArrVal_vdomain)
        with prems T.arr_Set_ArrVal_vrange show "x ∈∘ A ×∘ set {b}" by auto
      next
        fix x assume "x ∈∘ A ×∘ set {b}" 
        then obtain a where x_def: "x = ⟨a, b⟩" and "a ∈∘ A" by clarsimp
        have "𝒟∘ (T⦇ArrVal⦈) = A" by (simp add: smc_Set_cs_simps)
        moreover with 
          T.arr_Set_ArrVal_vrange T.ArrVal.vdomain_vrange_is_vempty ‹a ∈∘ A›   
        have "ℛ∘ (T⦇ArrVal⦈) = set {b}"
          by auto
        ultimately show "x ∈∘ T⦇ArrVal⦈"
          using ‹a ∈∘ A›
          unfolding x_def 
          by 
            (
              metis 
                T.ArrVal.vsv_ex1_app1 
                T.ArrVal.vsv_vimageI1 
                vimage_vdomain 
                vsingletonD
            )
      qed
      
      show "T = [A ×∘ set {b}, A, set {b}]∘"
      proof(rule arr_Set_eqI[of α], unfold arr_Rel_components)
        show "arr_Set α [A ×∘ set {b}, A, set {b}]∘"
          using T.arr_Rel_def T.arr_Set_axioms by auto
      qed (auto simp: T.arr_Set_axioms)

    qed
  qed

  then show ?thesis
    apply(intro iffI obj_terminalI)
    subgoal by (metis smc_is_arrD(2) obj_terminalE)
    subgoal by blast
    subgoal by (metis smc_Set_components(1))
    done

qed


text‹An object in ‹Set› is initial if and only if it is the empty 
set (see Chapter I-5 in \cite{mac_lane_categories_2010}).›

lemma (in 𝒵) smc_Set_obj_initial: "obj_initial (smc_Set α) A ⟷ A = 0"
proof-

  interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)

  have "(∀B∈∘Vset α. ∃!T. T : A ↦smc_Set α B) ⟷ A = 0" for A
  proof(intro iffI ballI)

    assume prems[rule_format]: "∀B∈∘Vset α. ∃!T. T : A ↦smc_Set α B" 

    then obtain T where T0B: "T : A ↦smc_Set α 0" by (meson vempty_is_zet)
    then have A[simp]: "A ∈∘ Vset α" by (fastforce simp: smc_Set_components(1))

    show "A = 0"
    proof(rule ccontr)
      assume "A ≠ 0"
      then obtain a where a: "a ∈∘ A" by (auto dest: trad_foundation)
      from Axiom_of_Powers a have A0: 
        "[A ×∘ set {0}, A, set {0}]∘ : A ↦smc_Set α set {0}"
        by 
          ( 
            intro smc_Set_is_arrI arr_Set_vfsequenceI, 
            unfold arr_Rel_components
          )
          auto
      have A1: "[A ×∘ set {1}, A, set {1}]∘ : A ↦smc_Set α set {1}"
      proof
          ( 
            intro smc_Set_is_arrI arr_Set_vfsequenceI, 
            unfold arr_Rel_components
          )
        show "set {1} ∈∘ Vset α" by (blast intro: vone_in_omega Axiom_of_Infinity)
      qed auto
      have "[A ×∘ set {0}, A, set {0, 1}]∘ : A ↦smc_Set α set {0, 1}"
      proof
        (
          intro smc_Set_is_arrI arr_Set_vfsequenceI, 
          unfold arr_Rel_components
        )
        show "set {[]∘, 1} ∈∘ Vset α"
          by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
      qed auto
      moreover have 
        "[A ×∘ set {1}, A, set {0, 1}]∘ : A ↦smc_Set α set {0, 1}"
      proof
        (
          intro smc_Set_is_arrI arr_Set_vfsequenceI, 
          unfold arr_Rel_components
        )
        show "set {[]∘, 1} ∈∘ Vset α"
          by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
      qed auto
      moreover from ‹A ≠ 0› one_neq_zero have 
        "[A ×∘ set {0}, A, set {0, 1}]∘ ≠ [A ×∘ set {1}, A, set {0, 1}]∘" 
        by (blast intro!: vsubset_antisym)
      ultimately show False 
        by (metis prems smc_is_arrE smc_Set_components(1))
    qed
  next
    fix B assume prems: "A = 0" "B ∈∘ Vset α"
    show "∃!T. T : A ↦smc_Set α B"
    proof(rule ex1I[of _ ‹[0, 0, B]∘›], unfold prems(1))
      show zzB: "[0, 0, B]∘ : 0 ↦smc_Set α B"
        by 
          (
            intro smc_Set_is_arrI arr_Set_vfsequenceI, 
            unfold arr_Rel_components
          )
          (simp_all add: prems)
      fix T assume prems: "T : 0 ↦smc_Set α B"
      interpret T: arr_Set α T
        rewrites [simp]: "T⦇ArrDom⦈ = 0" and [simp]: "T⦇ArrCod⦈ = B"
        using prems by (auto simp: smc_Set_is_arrD)
      show "T = [0, 0, B]∘"  
      proof(rule arr_Set_eqI[of α], unfold arr_Rel_components)
        show "arr_Set α T" by (rule T.arr_Set_axioms)
        from zzB show "arr_Set α [[]∘, []∘, B]∘" by (meson smc_Set_is_arrE)
        from T.ArrVal.vdomain_vrange_is_vempty show "T⦇ArrVal⦈ = []∘"
          by (auto intro: T.ArrVal.vsv_vrange_vempty simp: smc_Set_cs_simps)
      qed simp_all
    qed
  qed

  then show ?thesis 
    apply(intro iffI obj_initialI, elim obj_initialE)
    subgoal by (metis smc_Set_components(1))
    subgoal by (simp add: smc_Set_components(1))
    subgoal by (metis smc_Set_components(1))
    done

qed


text‹
There are no null objects in ‹Set› (this is a trivial corollary of the 
above).
›

lemma (in 𝒵) smc_Set_obj_null: "obj_null (smc_Set α) A ⟷ False"
  unfolding obj_null_def smc_Set_obj_terminal smc_Set_obj_initial by simp



subsection‹Zero arrow›


text‹
There are no zero arrows in ‹Set› (this result is a trivial 
corollary of the absence of null objects).
›

lemma (in 𝒵) smc_Set_is_zero_arr: "T : A ↦0smc_Set α B ⟷ False"
  using smc_Set_obj_null unfolding is_zero_arr_def by auto

text‹\newpage›

end

Theory CZH_SMC_Conclusions

(* Copyright 2021 (C) Mihails Milehins *)

theory CZH_SMC_Conclusions
  imports 
    CZH_SMC_Introduction
    CZH_SMC_Semicategory
    CZH_SMC_Small_Semicategory
    CZH_SMC_Semifunctor
    CZH_SMC_Small_Semifunctor
    CZH_SMC_NTSMCF
    CZH_SMC_Small_NTSMCF
    CZH_SMC_PSemicategory
    CZH_SMC_Subsemicategory
    CZH_SMC_Simple
    CZH_SMC_GRPH
    CZH_SMC_SemiCAT
    CZH_SMC_Rel
    CZH_SMC_Par
    CZH_SMC_Set
begin
end